{-# LANGUAGE FlexibleContexts #-}
module Text.XML.HXT.DTDValidation.DTDValidation
( removeDoublicateDefs
, validateDTD
)
where
import Text.XML.HXT.DTDValidation.AttributeValueValidation
import Text.XML.HXT.DTDValidation.TypeDefs
validateDTD :: XmlArrow
validateDTD :: XmlArrow
validateDTD
= forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isDTDDoctype
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]
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
>>>
( [[Char]] -> [[Char]] -> LA [XmlTree] XmlTree
validateParts forall (a :: * -> * -> *) c1 c2 b d.
ArrowList a =>
(c1 -> c2 -> a b d) -> a b (c1, c2) -> a b d
$<< (LA [XmlTree] [[Char]]
getNotationNames forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& LA [XmlTree] [[Char]]
getElemNames) )
)
where
validateParts :: [[Char]] -> [[Char]] -> LA [XmlTree] XmlTree
validateParts [[Char]]
notationNames [[Char]]
elemNames
= LA [XmlTree] XmlTree
validateNotations
forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+>
[[Char]] -> LA [XmlTree] XmlTree
validateEntities [[Char]]
notationNames
forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+>
[[Char]] -> LA [XmlTree] XmlTree
validateElements [[Char]]
elemNames
forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+>
[[Char]] -> [[Char]] -> LA [XmlTree] XmlTree
validateAttributes [[Char]]
elemNames [[Char]]
notationNames
getNotationNames :: LA [XmlTree] [String]
getNotationNames :: LA [XmlTree] [[Char]]
getNotationNames = forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b [c]
listA forall a b. (a -> b) -> a -> b
$ 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 :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isDTDNotation 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 => [Char] -> a XmlTree [Char]
getDTDAttrValue [Char]
a_name
getElemNames :: LA [XmlTree] [String]
getElemNames :: LA [XmlTree] [[Char]]
getElemNames = forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b [c]
listA forall a b. (a -> b) -> a -> b
$ 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 :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isDTDElement 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 => [Char] -> a XmlTree [Char]
getDTDAttrValue [Char]
a_name
checkName :: String -> SLA [String] XmlTree XmlTree -> SLA [String] XmlTree XmlTree
checkName :: [Char]
-> SLA [[Char]] XmlTree XmlTree -> SLA [[Char]] XmlTree XmlTree
checkName [Char]
name SLA [[Char]] XmlTree XmlTree
msg
= 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 ([Char]
name forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem`)
)
SLA [[Char]] XmlTree XmlTree
msg
(forall s (a :: * -> * -> *) b. ArrowState s a => (s -> s) -> a b s
nextState ([Char]
nameforall 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)
validateNotations :: LA XmlTrees XmlTree
validateNotations :: LA [XmlTree] XmlTree
validateNotations
= 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 :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isDTDNotation
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
(Attributes -> SLA [[Char]] XmlTree XmlTree
checkForUniqueNotation forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< forall (a :: * -> * -> *). ArrowXml a => a XmlTree Attributes
getDTDAttrl)
)
where
checkForUniqueNotation :: Attributes -> SLA [String] XmlTree XmlTree
checkForUniqueNotation :: Attributes -> SLA [[Char]] XmlTree XmlTree
checkForUniqueNotation Attributes
al
= [Char]
-> SLA [[Char]] XmlTree XmlTree -> SLA [[Char]] XmlTree XmlTree
checkName [Char]
name forall a b. (a -> b) -> a -> b
$
forall (a :: * -> * -> *) n. ArrowXml a => [Char] -> a n XmlTree
err ( [Char]
"Notation "forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show [Char]
name forall a. [a] -> [a] -> [a]
++ [Char]
" was already specified." )
where
name :: [Char]
name = Attributes -> [Char]
dtd_name Attributes
al
validateEntities :: [String] -> LA XmlTrees XmlTree
validateEntities :: [[Char]] -> LA [XmlTree] XmlTree
validateEntities [[Char]]
notationNames
= ( 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 :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isDTDEntity
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
(Attributes -> SLA [[Char]] XmlTree XmlTree
checkForUniqueEntity forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< forall (a :: * -> * -> *). ArrowXml a => a XmlTree Attributes
getDTDAttrl)
)
)
forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+>
( 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 :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isUnparsedEntity
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
(Attributes -> XmlArrow
checkNotationDecl forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< forall (a :: * -> * -> *). ArrowXml a => a XmlTree Attributes
getDTDAttrl)
)
where
checkForUniqueEntity :: Attributes -> SLA [String] XmlTree XmlTree
checkForUniqueEntity :: Attributes -> SLA [[Char]] XmlTree XmlTree
checkForUniqueEntity Attributes
al
= [Char]
-> SLA [[Char]] XmlTree XmlTree -> SLA [[Char]] XmlTree XmlTree
checkName [Char]
name forall a b. (a -> b) -> a -> b
$
forall (a :: * -> * -> *) n. ArrowXml a => [Char] -> a n XmlTree
warn ( [Char]
"Entity "forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show [Char]
name forall a. [a] -> [a] -> [a]
++ [Char]
" was already specified. " forall a. [a] -> [a] -> [a]
++
[Char]
"First declaration will be used." )
where
name :: [Char]
name = Attributes -> [Char]
dtd_name Attributes
al
checkNotationDecl :: Attributes -> XmlArrow
checkNotationDecl :: Attributes -> XmlArrow
checkNotationDecl Attributes
al
| [Char]
notationName forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]]
notationNames
= forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
| Bool
otherwise
= forall (a :: * -> * -> *) n. ArrowXml a => [Char] -> a n XmlTree
err ( [Char]
"The notation " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show [Char]
notationName forall a. [a] -> [a] -> [a]
++ [Char]
" must be declared " forall a. [a] -> [a] -> [a]
++
[Char]
"when referenced in the unparsed entity declaration for " forall a. [a] -> [a] -> [a]
++
forall a. Show a => a -> [Char]
show [Char]
upEntityName forall a. [a] -> [a] -> [a]
++ [Char]
"."
)
where
notationName :: [Char]
notationName = forall k e. Eq k => k -> AssocList k [e] -> [e]
lookup1 [Char]
k_ndata Attributes
al
upEntityName :: [Char]
upEntityName = Attributes -> [Char]
dtd_name Attributes
al
validateElements :: [String] -> LA XmlTrees XmlTree
validateElements :: [[Char]] -> LA [XmlTree] XmlTree
validateElements [[Char]]
elemNames
= ( 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 :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isDTDElement
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
(Attributes -> SLA [[Char]] XmlTree XmlTree
checkForUniqueElement forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< forall (a :: * -> * -> *). ArrowXml a => a XmlTree Attributes
getDTDAttrl)
)
)
forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+>
( 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 :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isMixedContentElement
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
(Attributes -> XmlArrow
checkMixedContent forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< forall (a :: * -> * -> *). ArrowXml a => a XmlTree Attributes
getDTDAttrl)
)
forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+>
( 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 :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isDTDElement
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
([[Char]] -> Attributes -> XmlArrow
checkContentModel [[Char]]
elemNames forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< forall (a :: * -> * -> *). ArrowXml a => a XmlTree Attributes
getDTDAttrl)
)
where
checkForUniqueElement :: Attributes -> SLA [String] XmlTree XmlTree
checkForUniqueElement :: Attributes -> SLA [[Char]] XmlTree XmlTree
checkForUniqueElement Attributes
al
= [Char]
-> SLA [[Char]] XmlTree XmlTree -> SLA [[Char]] XmlTree XmlTree
checkName [Char]
name forall a b. (a -> b) -> a -> b
$
forall (a :: * -> * -> *) n. ArrowXml a => [Char] -> a n XmlTree
err ( [Char]
"Element type " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show [Char]
name forall a. [a] -> [a] -> [a]
++
[Char]
" must not be declared more than once." )
where
name :: [Char]
name = Attributes -> [Char]
dtd_name Attributes
al
checkMixedContent :: Attributes -> XmlArrow
checkMixedContent :: Attributes -> XmlArrow
checkMixedContent Attributes
al
= forall (a :: * -> * -> *) s b c.
ArrowList a =>
s -> SLA s b c -> a b c
fromSLA [] ( 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 :: * -> * -> *) (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
isDTDName
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
(Attributes -> SLA [[Char]] XmlTree XmlTree
check forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< forall (a :: * -> * -> *). ArrowXml a => a XmlTree Attributes
getDTDAttrl)
)
where
elemName :: [Char]
elemName = Attributes -> [Char]
dtd_name Attributes
al
check :: Attributes -> SLA [[Char]] XmlTree XmlTree
check Attributes
al'
= [Char]
-> SLA [[Char]] XmlTree XmlTree -> SLA [[Char]] XmlTree XmlTree
checkName [Char]
name forall a b. (a -> b) -> a -> b
$
forall (a :: * -> * -> *) n. ArrowXml a => [Char] -> a n XmlTree
err ( [Char]
"The element type " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show [Char]
name forall a. [a] -> [a] -> [a]
++
[Char]
" was already specified in the mixed-content model of the element declaration " forall a. [a] -> [a] -> [a]
++
forall a. Show a => a -> [Char]
show [Char]
elemName forall a. [a] -> [a] -> [a]
++ [Char]
"." )
where
name :: [Char]
name = Attributes -> [Char]
dtd_name Attributes
al'
checkContentModel :: [String] -> Attributes -> XmlArrow
checkContentModel :: [[Char]] -> Attributes -> XmlArrow
checkContentModel [[Char]]
names Attributes
al
| [Char]
cm forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]
v_children, [Char]
v_mixed]
= 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
>>> XmlArrow
checkContent
| Bool
otherwise
= forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
where
elemName :: [Char]
elemName = Attributes -> [Char]
dtd_name Attributes
al
cm :: [Char]
cm = Attributes -> [Char]
dtd_type Attributes
al
checkContent :: XmlArrow
checkContent :: XmlArrow
checkContent
= forall (a :: * -> * -> *) b c d.
ArrowIf a =>
[IfThen (a b c) (a b d)] -> a b d
choiceA
[ forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isDTDName forall a b. a -> b -> IfThen a b
:-> ( forall {a :: * -> * -> *} {b}.
ArrowXml a =>
Attributes -> a b XmlTree
checkName' forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< forall (a :: * -> * -> *). ArrowXml a => a XmlTree Attributes
getDTDAttrl )
, forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isDTDContent forall a b. a -> b -> IfThen a b
:-> ( 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
>>> XmlArrow
checkContent )
, 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
]
where
checkName' :: Attributes -> a b XmlTree
checkName' Attributes
al'
| [Char]
childElemName forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]]
names
= forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
| Bool
otherwise
= forall (a :: * -> * -> *) n. ArrowXml a => [Char] -> a n XmlTree
warn ( [Char]
"The element type "forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show [Char]
childElemName forall a. [a] -> [a] -> [a]
++
[Char]
", used in content model of element "forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show [Char]
elemName forall a. [a] -> [a] -> [a]
++
[Char]
", is not declared."
)
where
childElemName :: [Char]
childElemName = Attributes -> [Char]
dtd_name Attributes
al'
validateAttributes :: [String] -> [String] -> LA XmlTrees XmlTree
validateAttributes :: [[Char]] -> [[Char]] -> LA [XmlTree] XmlTree
validateAttributes [[Char]]
elemNames [[Char]]
notationNames
=
( forall {cat :: * -> * -> *} {c}.
ArrowDTD cat =>
cat XmlTree XmlTree
-> (Attributes -> cat XmlTree c) -> cat [XmlTree] c
runCheck forall (a :: * -> * -> *) b. ArrowList a => a b b
this ([[Char]] -> Attributes -> XmlArrow
checkDeclaredElements [[Char]]
elemNames) )
forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+>
( forall {a :: * -> * -> *} {a} {c}.
ArrowList a =>
SLA [a] XmlTree XmlTree
-> (Attributes -> SLA [a] XmlTree c) -> a [XmlTree] c
runNameCheck forall (a :: * -> * -> *) b. ArrowList a => a b b
this Attributes -> SLA [[Char]] XmlTree XmlTree
checkForUniqueAttributeDeclaration )
forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+>
( forall {cat :: * -> * -> *} {c}.
ArrowDTD cat =>
cat XmlTree XmlTree
-> (Attributes -> cat XmlTree c) -> cat [XmlTree] c
runCheck (forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isEnumAttrType forall (a :: * -> * -> *) b c. ArrowIf a => a b c -> a b c -> a b c
`orElse` forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isNotationAttrType) Attributes -> XmlArrow
checkEnumeratedTypes )
forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+>
( forall {a :: * -> * -> *} {a} {c}.
ArrowList a =>
SLA [a] XmlTree XmlTree
-> (Attributes -> SLA [a] XmlTree c) -> a [XmlTree] c
runNameCheck forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isIdAttrType Attributes -> SLA [[Char]] XmlTree XmlTree
checkForUniqueId )
forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+>
( forall {a :: * -> * -> *} {a} {c}.
ArrowList a =>
SLA [a] XmlTree XmlTree
-> (Attributes -> SLA [a] XmlTree c) -> a [XmlTree] c
runNameCheck forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isNotationAttrType Attributes -> SLA [[Char]] XmlTree XmlTree
checkForUniqueNotation )
forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+>
( forall {cat :: * -> * -> *} {c}.
ArrowDTD cat =>
cat XmlTree XmlTree
-> (Attributes -> cat XmlTree c) -> cat [XmlTree] c
runCheck forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isIdAttrType Attributes -> XmlArrow
checkIdKindConstraint )
forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+>
( forall {cat :: * -> * -> *} {c}.
ArrowDTD cat =>
cat XmlTree XmlTree
-> (Attributes -> cat XmlTree c) -> cat [XmlTree] c
runCheck forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isNotationAttrType ([[Char]] -> Attributes -> XmlArrow
checkNotationDeclaration [[Char]]
notationNames) )
forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+>
( [[Char]] -> LA [XmlTree] XmlTree
checkNoNotationForEmptyElements 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 ( 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 :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isEmptyElement
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 => [Char] -> a XmlTree [Char]
getDTDAttrValue [Char]
a_name
)
)
forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+>
( [XmlTree] -> LA [XmlTree] XmlTree
checkDefaultValueTypes forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< forall (a :: * -> * -> *) b. ArrowList a => a b b
this )
where
runCheck :: cat XmlTree XmlTree
-> (Attributes -> cat XmlTree c) -> cat [XmlTree] c
runCheck cat XmlTree XmlTree
select Attributes -> cat XmlTree c
check
= 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 :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isDTDAttlist
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
cat XmlTree XmlTree
select
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
(Attributes -> cat XmlTree c
check forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< forall (a :: * -> * -> *). ArrowXml a => a XmlTree Attributes
getDTDAttrl)
runNameCheck :: SLA [a] XmlTree XmlTree
-> (Attributes -> SLA [a] XmlTree c) -> a [XmlTree] c
runNameCheck SLA [a] XmlTree XmlTree
select Attributes -> SLA [a] XmlTree c
check
= forall (a :: * -> * -> *) s b c.
ArrowList a =>
s -> SLA s b c -> a b c
fromSLA [] forall a b. (a -> b) -> a -> b
$ forall {cat :: * -> * -> *} {c}.
ArrowDTD cat =>
cat XmlTree XmlTree
-> (Attributes -> cat XmlTree c) -> cat [XmlTree] c
runCheck SLA [a] XmlTree XmlTree
select Attributes -> SLA [a] XmlTree c
check
checkDeclaredElements :: [String] -> Attributes -> XmlArrow
checkDeclaredElements :: [[Char]] -> Attributes -> XmlArrow
checkDeclaredElements [[Char]]
elemNames' Attributes
al
| [Char]
en forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]]
elemNames'
= forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
| Bool
otherwise
= forall (a :: * -> * -> *) n. ArrowXml a => [Char] -> a n XmlTree
warn ( [Char]
"The element type \""forall a. [a] -> [a] -> [a]
++ [Char]
en forall a. [a] -> [a] -> [a]
++ [Char]
"\" used in dclaration "forall a. [a] -> [a] -> [a]
++
[Char]
"of attribute \""forall a. [a] -> [a] -> [a]
++ [Char]
an forall a. [a] -> [a] -> [a]
++[Char]
"\" is not declared."
)
where
en :: [Char]
en = Attributes -> [Char]
dtd_name Attributes
al
an :: [Char]
an = Attributes -> [Char]
dtd_value Attributes
al
checkForUniqueAttributeDeclaration :: Attributes -> SLA [String] XmlTree XmlTree
checkForUniqueAttributeDeclaration :: Attributes -> SLA [[Char]] XmlTree XmlTree
checkForUniqueAttributeDeclaration Attributes
al
= [Char]
-> SLA [[Char]] XmlTree XmlTree -> SLA [[Char]] XmlTree XmlTree
checkName [Char]
name forall a b. (a -> b) -> a -> b
$
forall (a :: * -> * -> *) n. ArrowXml a => [Char] -> a n XmlTree
warn ( [Char]
"Attribute \""forall a. [a] -> [a] -> [a]
++ [Char]
aname forall a. [a] -> [a] -> [a]
++[Char]
"\" for element type \""forall a. [a] -> [a] -> [a]
++
[Char]
ename forall a. [a] -> [a] -> [a]
++[Char]
"\" is already declared. First "forall a. [a] -> [a] -> [a]
++
[Char]
"declaration will be used." )
where
ename :: [Char]
ename = Attributes -> [Char]
dtd_name Attributes
al
aname :: [Char]
aname = Attributes -> [Char]
dtd_value Attributes
al
name :: [Char]
name = [Char]
ename forall a. [a] -> [a] -> [a]
++ [Char]
"|" forall a. [a] -> [a] -> [a]
++ [Char]
aname
checkEnumeratedTypes :: Attributes -> XmlArrow
checkEnumeratedTypes :: Attributes -> XmlArrow
checkEnumeratedTypes Attributes
al
= forall (a :: * -> * -> *) s b c.
ArrowList a =>
s -> SLA s b c -> a b c
fromSLA [] ( 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
isDTDName
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
(Attributes -> SLA [[Char]] XmlTree XmlTree
checkForUniqueType forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< forall (a :: * -> * -> *). ArrowXml a => a XmlTree Attributes
getDTDAttrl)
)
where
checkForUniqueType :: Attributes -> SLA [String] XmlTree XmlTree
checkForUniqueType :: Attributes -> SLA [[Char]] XmlTree XmlTree
checkForUniqueType Attributes
al'
= [Char]
-> SLA [[Char]] XmlTree XmlTree -> SLA [[Char]] XmlTree XmlTree
checkName [Char]
nmtoken forall a b. (a -> b) -> a -> b
$
forall (a :: * -> * -> *) n. ArrowXml a => [Char] -> a n XmlTree
warn ( [Char]
"Nmtoken \""forall a. [a] -> [a] -> [a]
++ [Char]
nmtoken forall a. [a] -> [a] -> [a]
++[Char]
"\" should not "forall a. [a] -> [a] -> [a]
++
[Char]
"occur more than once in attribute \""forall a. [a] -> [a] -> [a]
++ Attributes -> [Char]
dtd_value Attributes
al forall a. [a] -> [a] -> [a]
++
[Char]
"\" for element \""forall a. [a] -> [a] -> [a]
++ Attributes -> [Char]
dtd_name Attributes
al forall a. [a] -> [a] -> [a]
++ [Char]
"\"." )
where
nmtoken :: [Char]
nmtoken = Attributes -> [Char]
dtd_name Attributes
al'
checkForUniqueId :: Attributes -> SLA [String] XmlTree XmlTree
checkForUniqueId :: Attributes -> SLA [[Char]] XmlTree XmlTree
checkForUniqueId Attributes
al
= [Char]
-> SLA [[Char]] XmlTree XmlTree -> SLA [[Char]] XmlTree XmlTree
checkName [Char]
ename forall a b. (a -> b) -> a -> b
$
forall (a :: * -> * -> *) n. ArrowXml a => [Char] -> a n XmlTree
err ( [Char]
"Element \""forall a. [a] -> [a] -> [a]
++ [Char]
ename forall a. [a] -> [a] -> [a]
++ [Char]
"\" already has attribute of type "forall a. [a] -> [a] -> [a]
++
[Char]
"ID, another attribute \""forall a. [a] -> [a] -> [a]
++ Attributes -> [Char]
dtd_value Attributes
al forall a. [a] -> [a] -> [a]
++ [Char]
"\" of type ID is "forall a. [a] -> [a] -> [a]
++
[Char]
"not permitted." )
where
ename :: [Char]
ename = Attributes -> [Char]
dtd_name Attributes
al
checkForUniqueNotation :: Attributes -> SLA [String] XmlTree XmlTree
checkForUniqueNotation :: Attributes -> SLA [[Char]] XmlTree XmlTree
checkForUniqueNotation Attributes
al
= [Char]
-> SLA [[Char]] XmlTree XmlTree -> SLA [[Char]] XmlTree XmlTree
checkName [Char]
ename forall a b. (a -> b) -> a -> b
$
forall (a :: * -> * -> *) n. ArrowXml a => [Char] -> a n XmlTree
err ( [Char]
"Element \""forall a. [a] -> [a] -> [a]
++ [Char]
ename forall a. [a] -> [a] -> [a]
++ [Char]
"\" already has attribute of type "forall a. [a] -> [a] -> [a]
++
[Char]
"NOTATION, another attribute \""forall a. [a] -> [a] -> [a]
++ Attributes -> [Char]
dtd_value Attributes
al forall a. [a] -> [a] -> [a]
++ [Char]
"\" of type NOTATION "forall a. [a] -> [a] -> [a]
++
[Char]
"is not permitted." )
where
ename :: [Char]
ename = Attributes -> [Char]
dtd_name Attributes
al
checkIdKindConstraint :: Attributes -> XmlArrow
checkIdKindConstraint :: Attributes -> XmlArrow
checkIdKindConstraint Attributes
al
| [Char]
attKind forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]
k_implied, [Char]
k_required]
= forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
| Bool
otherwise
= forall (a :: * -> * -> *) n. ArrowXml a => [Char] -> a n XmlTree
err ( [Char]
"ID attribute \""forall a. [a] -> [a] -> [a]
++ Attributes -> [Char]
dtd_value Attributes
al forall a. [a] -> [a] -> [a]
++[Char]
"\" must have a declared default "forall a. [a] -> [a] -> [a]
++
[Char]
"of \"#IMPLIED\" or \"REQUIRED\"")
where
attKind :: [Char]
attKind = Attributes -> [Char]
dtd_kind Attributes
al
checkNotationDeclaration :: [String] -> Attributes -> XmlArrow
checkNotationDeclaration :: [[Char]] -> Attributes -> XmlArrow
checkNotationDeclaration [[Char]]
notations Attributes
al
= 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
isDTDName
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
(Attributes -> XmlArrow
checkNotations forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< forall (a :: * -> * -> *). ArrowXml a => a XmlTree Attributes
getDTDAttrl)
where
checkNotations :: Attributes -> XmlArrow
checkNotations :: Attributes -> XmlArrow
checkNotations Attributes
al'
| [Char]
notation forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]]
notations
= forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
| Bool
otherwise
= forall (a :: * -> * -> *) n. ArrowXml a => [Char] -> a n XmlTree
err ( [Char]
"The notation \""forall a. [a] -> [a] -> [a]
++ [Char]
notation forall a. [a] -> [a] -> [a]
++[Char]
"\" must be declared when "forall a. [a] -> [a] -> [a]
++
[Char]
"referenced in the notation type list for attribute \""forall a. [a] -> [a] -> [a]
++ Attributes -> [Char]
dtd_value Attributes
al forall a. [a] -> [a] -> [a]
++
[Char]
"\" of element \""forall a. [a] -> [a] -> [a]
++ Attributes -> [Char]
dtd_name Attributes
al forall a. [a] -> [a] -> [a]
++[Char]
"\"."
)
where
notation :: [Char]
notation = Attributes -> [Char]
dtd_name Attributes
al'
checkNoNotationForEmptyElements :: [String] -> LA XmlTrees XmlTree
checkNoNotationForEmptyElements :: [[Char]] -> LA [XmlTree] XmlTree
checkNoNotationForEmptyElements [[Char]]
emptyElems
= 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 :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isDTDAttlist
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
isNotationAttrType
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
(Attributes -> XmlArrow
checkNoNotationForEmptyElement forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< forall (a :: * -> * -> *). ArrowXml a => a XmlTree Attributes
getDTDAttrl)
where
checkNoNotationForEmptyElement :: Attributes -> XmlArrow
checkNoNotationForEmptyElement :: Attributes -> XmlArrow
checkNoNotationForEmptyElement Attributes
al
| [Char]
ename forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]]
emptyElems
= forall (a :: * -> * -> *) n. ArrowXml a => [Char] -> a n XmlTree
err ( [Char]
"Attribute \""forall a. [a] -> [a] -> [a]
++ Attributes -> [Char]
dtd_value Attributes
al forall a. [a] -> [a] -> [a]
++[Char]
"\" of type NOTATION must not be "forall a. [a] -> [a] -> [a]
++
[Char]
"declared on the element \""forall a. [a] -> [a] -> [a]
++ [Char]
ename forall a. [a] -> [a] -> [a]
++[Char]
"\" declared EMPTY."
)
| Bool
otherwise
= forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
where
ename :: [Char]
ename = Attributes -> [Char]
dtd_name Attributes
al
checkDefaultValueTypes :: XmlTrees -> LA XmlTrees XmlTree
checkDefaultValueTypes :: [XmlTree] -> LA [XmlTree] XmlTree
checkDefaultValueTypes [XmlTree]
dtdPart'
= 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 :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isDTDAttlist
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
isDefaultAttrKind
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
([XmlTree] -> XmlTree -> XmlArrow
checkAttributeValue [XmlTree]
dtdPart' forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< forall (a :: * -> * -> *) b. ArrowList a => a b b
this)
removeDoublicateDefs :: XmlArrow
removeDoublicateDefs :: XmlArrow
removeDoublicateDefs
= forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b) -> a (t b) (t b)
replaceChildren
( forall (a :: * -> * -> *) s b c.
ArrowList a =>
s -> SLA s b c -> a b c
fromSLA [] ( 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 d.
ArrowIf a =>
[IfThen (a b c) (a b d)] -> a b d
choiceA [ forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isDTDAttlist forall a b. a -> b -> IfThen a b
:-> (Attributes -> SLA [[Char]] XmlTree XmlTree
removeDoubleAttlist forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< forall (a :: * -> * -> *). ArrowXml a => a XmlTree Attributes
getDTDAttrl)
, forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isDTDEntity forall a b. a -> b -> IfThen a b
:-> (Attributes -> SLA [[Char]] XmlTree XmlTree
removeDoubleEntity forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< forall (a :: * -> * -> *). ArrowXml a => a XmlTree Attributes
getDTDAttrl)
, forall (a :: * -> * -> *) b. ArrowList a => a b b
this forall a b. a -> b -> IfThen a b
:-> forall (a :: * -> * -> *) b. ArrowList a => a b b
this
]
)
)
forall (a :: * -> * -> *) b c. ArrowIf a => a b b -> a b c -> a b b
`when`
forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isDTDDoctype
where
checkName' :: a -> a d d
checkName' a
n'
= 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 (a
n' forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem`)
)
forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
(forall (a :: * -> * -> *) b. ArrowList a => a b b
this 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 -> a b b
perform (forall s (a :: * -> * -> *) b. ArrowState s a => (s -> s) -> a b s
nextState (a
n'forall a. a -> [a] -> [a]
:)))
removeDoubleAttlist :: Attributes -> SLA [String] XmlTree XmlTree
removeDoubleAttlist :: Attributes -> SLA [[Char]] XmlTree XmlTree
removeDoubleAttlist Attributes
al
= forall {a} {a :: * -> * -> *} {d}.
(ArrowState [a] a, Eq a, ArrowIf a) =>
a -> a d d
checkName' [Char]
elemAttr
where
elemAttr :: [Char]
elemAttr = [Char]
elemName forall a. [a] -> [a] -> [a]
++ [Char]
"|" forall a. [a] -> [a] -> [a]
++ [Char]
attrName
attrName :: [Char]
attrName = Attributes -> [Char]
dtd_value Attributes
al
elemName :: [Char]
elemName = Attributes -> [Char]
dtd_name Attributes
al
removeDoubleEntity :: Attributes -> SLA [String] XmlTree XmlTree
removeDoubleEntity :: Attributes -> SLA [[Char]] XmlTree XmlTree
removeDoubleEntity Attributes
al
= forall {a} {a :: * -> * -> *} {d}.
(ArrowState [a] a, Eq a, ArrowIf a) =>
a -> a d d
checkName' (Attributes -> [Char]
dtd_name Attributes
al)