module Text.XML.HXT.DTDValidation.AttributeValueValidation
( checkAttributeValue
, normalizeAttributeValue
)
where
import Text.XML.HXT.Parser.XmlParsec
( parseNMToken
, parseName
)
import Text.XML.HXT.DTDValidation.TypeDefs
checkAttributeValue :: XmlTrees -> XmlTree -> XmlArrow
checkAttributeValue :: XmlTrees -> XmlTree -> XmlArrow
checkAttributeValue XmlTrees
dtdPart XmlTree
attrDecl
| XmlTree -> Bool
isDTDAttlistNode XmlTree
attrDecl
= 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
:-> ( String -> XmlArrow
checkAttrVal 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 )
, forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isDTDAttlist forall a b. a -> b -> IfThen a b
:-> ( String -> XmlArrow
checkAttrVal 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 d.
Arrow a =>
a b c -> (c -> d) -> a b d
>>^ Attributes -> String
dtd_default) )
, 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
]
| Bool
otherwise
= forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
where
al :: Attributes
al = XmlTree -> Attributes
getDTDAttributes XmlTree
attrDecl
attrName :: String
attrName = Attributes -> String
dtd_value Attributes
al
attrType :: String
attrType = Attributes -> String
dtd_type Attributes
al
checkAttrVal :: String -> XmlArrow
checkAttrVal String
attrValue
= String -> XmlTrees -> String -> XmlTree -> XmlArrow
checkValue String
attrType XmlTrees
dtdPart String
normalizedVal XmlTree
attrDecl
where
normalizedVal :: String
normalizedVal = Maybe XmlTree -> String -> String
normalizeAttributeValue (forall a. a -> Maybe a
Just XmlTree
attrDecl) String
attrValue
checkValue :: String -> XmlTrees -> String -> XmlTree -> XmlArrow
checkValue :: String -> XmlTrees -> String -> XmlTree -> XmlArrow
checkValue String
typ XmlTrees
dtdPart String
attrValue XmlTree
attrDecl
| String
typ forall a. Eq a => a -> a -> Bool
== String
k_cdata = forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
| String
typ forall a. Eq a => a -> a -> Bool
== String
k_enumeration = XmlTree -> String -> XmlArrow
checkValueEnumeration XmlTree
attrDecl String
attrValue
| String
typ forall a. Eq a => a -> a -> Bool
== String
k_entity = XmlTrees -> XmlTree -> String -> XmlArrow
checkValueEntity XmlTrees
dtdPart XmlTree
attrDecl String
attrValue
| String
typ forall a. Eq a => a -> a -> Bool
== String
k_entities = XmlTrees -> XmlTree -> String -> XmlArrow
checkValueEntities XmlTrees
dtdPart XmlTree
attrDecl String
attrValue
| String
typ forall a. Eq a => a -> a -> Bool
== String
k_id = XmlTree -> String -> XmlArrow
checkValueId XmlTree
attrDecl String
attrValue
| String
typ forall a. Eq a => a -> a -> Bool
== String
k_idref = XmlTree -> String -> XmlArrow
checkValueIdref XmlTree
attrDecl String
attrValue
| String
typ forall a. Eq a => a -> a -> Bool
== String
k_idrefs = XmlTree -> String -> XmlArrow
checkValueIdrefs XmlTree
attrDecl String
attrValue
| String
typ forall a. Eq a => a -> a -> Bool
== String
k_nmtoken = XmlTree -> String -> XmlArrow
checkValueNmtoken XmlTree
attrDecl String
attrValue
| String
typ forall a. Eq a => a -> a -> Bool
== String
k_nmtokens = XmlTree -> String -> XmlArrow
checkValueNmtokens XmlTree
attrDecl String
attrValue
| String
typ forall a. Eq a => a -> a -> Bool
== String
k_notation = XmlTree -> String -> XmlArrow
checkValueEnumeration XmlTree
attrDecl String
attrValue
| Bool
otherwise = forall a. HasCallStack => String -> a
error (String
"Attribute type " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
typ forall a. [a] -> [a] -> [a]
++ String
" unknown.")
checkValueEnumeration :: XmlTree -> String -> XmlArrow
checkValueEnumeration :: XmlTree -> String -> XmlArrow
checkValueEnumeration XmlTree
attrDecl String
attrValue
| XmlTree -> Bool
isDTDAttlistNode XmlTree
attrDecl
Bool -> Bool -> Bool
&&
String
attrValue forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [String]
enumVals
= forall (a :: * -> * -> *) n. ArrowXml a => String -> a n XmlTree
err ( String
"Attribute " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Attributes -> String
dtd_value Attributes
al) forall a. [a] -> [a] -> [a]
++ String
" for element " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Attributes -> String
dtd_name Attributes
al) forall a. [a] -> [a] -> [a]
++
String
" must have a value from list "forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show [String]
enumVals forall a. [a] -> [a] -> [a]
++ String
".")
| Bool
otherwise
= forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
where
al :: Attributes
al = XmlTree -> Attributes
getDTDAttributes XmlTree
attrDecl
enumVals :: [String]
enumVals :: [String]
enumVals = forall a b. (a -> b) -> [a] -> [b]
map (Attributes -> String
dtd_name forall b c a. (b -> c) -> (a -> b) -> a -> c
. XmlTree -> Attributes
getDTDAttributes) forall a b. (a -> b) -> a -> b
$ (forall a b. LA a b -> a -> [b]
runLA forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b)
getChildren XmlTree
attrDecl)
checkValueEntity :: XmlTrees -> XmlTree -> String -> XmlArrow
checkValueEntity :: XmlTrees -> XmlTree -> String -> XmlArrow
checkValueEntity XmlTrees
dtdPart XmlTree
attrDecl String
attrValue
| XmlTree -> Bool
isDTDAttlistNode XmlTree
attrDecl
Bool -> Bool -> Bool
&&
String
attrValue forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [String]
upEntities
= forall (a :: * -> * -> *) n. ArrowXml a => String -> a n XmlTree
err ( String
"Entity " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
attrValue forall a. [a] -> [a] -> [a]
++ String
" of attribute " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Attributes -> String
dtd_value Attributes
al) forall a. [a] -> [a] -> [a]
++
String
" for element " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Attributes -> String
dtd_name Attributes
al) forall a. [a] -> [a] -> [a]
++ String
" is not unparsed. " forall a. [a] -> [a] -> [a]
++
String
"The following unparsed entities exist: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show [String]
upEntities forall a. [a] -> [a] -> [a]
++ String
".")
| Bool
otherwise
= forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
where
al :: Attributes
al = XmlTree -> Attributes
getDTDAttributes XmlTree
attrDecl
upEntities :: [String]
upEntities :: [String]
upEntities = forall a b. (a -> b) -> [a] -> [b]
map (Attributes -> String
dtd_name forall b c a. (b -> c) -> (a -> b) -> a -> c
. XmlTree -> Attributes
getDTDAttributes) (forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isUnparsedEntity XmlArrow -> XmlTrees -> XmlTrees
$$ XmlTrees
dtdPart)
checkValueEntities ::XmlTrees -> XmlTree -> String -> XmlArrow
checkValueEntities :: XmlTrees -> XmlTree -> String -> XmlArrow
checkValueEntities XmlTrees
dtdPart XmlTree
attrDecl String
attrValue
| XmlTree -> Bool
isDTDAttlistNode XmlTree
attrDecl
= if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
valueList
then forall (a :: * -> * -> *) n. ArrowXml a => String -> a n XmlTree
err (String
"Attribute " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Attributes -> String
dtd_value Attributes
al) forall a. [a] -> [a] -> [a]
++ String
" of element " forall a. [a] -> [a] -> [a]
++
forall a. Show a => a -> String
show (Attributes -> String
dtd_name Attributes
al) forall a. [a] -> [a] -> [a]
++ String
" must be one or more names.")
else 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 (XmlTrees -> XmlTree -> String -> XmlArrow
checkValueEntity XmlTrees
dtdPart XmlTree
attrDecl) forall a b. (a -> b) -> a -> b
$ [String]
valueList
| Bool
otherwise
= forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
where
al :: Attributes
al = XmlTree -> Attributes
getDTDAttributes XmlTree
attrDecl
valueList :: [String]
valueList = String -> [String]
words String
attrValue
checkValueNmtoken :: XmlTree -> String -> XmlArrow
checkValueNmtoken :: XmlTree -> String -> XmlArrow
checkValueNmtoken XmlTree
attrDecl String
attrValue
| XmlTree -> Bool
isDTDAttlistNode XmlTree
attrDecl
= forall (a :: * -> * -> *) c b. ArrowList a => c -> a b c
constA String
attrValue 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
checkNmtoken
| Bool
otherwise
= forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
where
al :: Attributes
al = XmlTree -> Attributes
getDTDAttributes XmlTree
attrDecl
checkNmtoken :: LA String XmlTree
checkNmtoken
= forall (a :: * -> * -> *). ArrowXml a => a String XmlTree
mkText 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 => (b -> [c]) -> a b c
arrL (String -> XmlTree -> XmlTrees
parseNMToken String
"")
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
isError
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
getErrorMsg
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 (\ String
s -> ( String
"Attribute value " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
attrValue forall a. [a] -> [a] -> [a]
++ String
" of attribute " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Attributes -> String
dtd_value Attributes
al) forall a. [a] -> [a] -> [a]
++
String
" for element " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Attributes -> String
dtd_name Attributes
al) forall a. [a] -> [a] -> [a]
++ String
" must be a name token, "forall a. [a] -> [a] -> [a]
++ (String -> [String]
lines String
s) forall a. [a] -> Int -> a
!! Int
1 forall a. [a] -> [a] -> [a]
++String
".") )
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 => Int -> a String XmlTree
mkError Int
c_err
checkValueNmtokens :: XmlTree -> String -> XmlArrow
checkValueNmtokens :: XmlTree -> String -> XmlArrow
checkValueNmtokens XmlTree
attrDecl String
attrValue
| XmlTree -> Bool
isDTDAttlistNode XmlTree
attrDecl
= if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
valueList
then forall (a :: * -> * -> *) n. ArrowXml a => String -> a n XmlTree
err ( String
"Attribute "forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Attributes -> String
dtd_value Attributes
al) forall a. [a] -> [a] -> [a]
++String
" of element " forall a. [a] -> [a] -> [a]
++
forall a. Show a => a -> String
show (Attributes -> String
dtd_name Attributes
al) forall a. [a] -> [a] -> [a]
++ String
" must be one or more name tokens.")
else 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 -> String -> XmlArrow
checkValueNmtoken XmlTree
attrDecl) forall a b. (a -> b) -> a -> b
$ [String]
valueList
| Bool
otherwise
= forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
where
al :: Attributes
al = XmlTree -> Attributes
getDTDAttributes XmlTree
attrDecl
valueList :: [String]
valueList = String -> [String]
words String
attrValue
checkValueId :: XmlTree -> String -> XmlArrow
checkValueId :: XmlTree -> String -> XmlArrow
checkValueId XmlTree
attrDecl String
attrValue
= String -> XmlTree -> String -> XmlArrow
checkForName String
"Attribute value" XmlTree
attrDecl String
attrValue
checkValueIdref :: XmlTree -> String -> XmlArrow
checkValueIdref :: XmlTree -> String -> XmlArrow
checkValueIdref XmlTree
attrDecl String
attrValue
= String -> XmlTree -> String -> XmlArrow
checkForName String
"Attribute value" XmlTree
attrDecl String
attrValue
checkValueIdrefs :: XmlTree -> String -> XmlArrow
checkValueIdrefs :: XmlTree -> String -> XmlArrow
checkValueIdrefs XmlTree
attrDecl String
attrValue
= 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 -> String -> XmlArrow
checkValueIdref XmlTree
attrDecl) forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
words forall a b. (a -> b) -> a -> b
$ String
attrValue
checkForName :: String -> XmlTree -> String -> XmlArrow
checkForName :: String -> XmlTree -> String -> XmlArrow
checkForName String
msg XmlTree
attrDecl String
attrValue
| XmlTree -> Bool
isDTDAttlistNode XmlTree
attrDecl
= forall (a :: * -> * -> *) c b. ArrowList a => c -> a b c
constA String
attrValue 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
checkName
| Bool
otherwise
= forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
where
al :: Attributes
al = XmlTree -> Attributes
getDTDAttributes XmlTree
attrDecl
checkName :: LA String XmlTree
checkName
= forall (a :: * -> * -> *). ArrowXml a => a String XmlTree
mkText 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 => (b -> [c]) -> a b c
arrL (String -> XmlTree -> XmlTrees
parseName String
"")
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
isError
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
getErrorMsg
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 (\String
s -> ( String
msg forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
attrValue forall a. [a] -> [a] -> [a]
++String
" of attribute " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Attributes -> String
dtd_value Attributes
al) forall a. [a] -> [a] -> [a]
++
String
" for element "forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Attributes -> String
dtd_name Attributes
al) forall a. [a] -> [a] -> [a]
++String
" must be a name, " forall a. [a] -> [a] -> [a]
++ (String -> [String]
lines String
s) forall a. [a] -> Int -> a
!! Int
1 forall a. [a] -> [a] -> [a]
++ String
".") )
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 => Int -> a String XmlTree
mkError Int
c_err
normalizeAttributeValue :: Maybe XmlTree -> String -> String
normalizeAttributeValue :: Maybe XmlTree -> String -> String
normalizeAttributeValue (Just XmlTree
attrDecl) String
value
= String -> String
normalizeAttribute String
attrType
where
al :: Attributes
al = XmlTree -> Attributes
getDTDAttributes XmlTree
attrDecl
attrType :: String
attrType = Attributes -> String
dtd_type Attributes
al
normalizeAttribute :: String -> String
normalizeAttribute :: String -> String
normalizeAttribute String
typ
| String
typ forall a. Eq a => a -> a -> Bool
== String
k_cdata = String -> String
cdataNormalization String
value
| Bool
otherwise = String -> String
otherNormalization String
value
normalizeAttributeValue Maybe XmlTree
Nothing String
value
= String -> String
cdataNormalization String
value
cdataNormalization :: String -> String
cdataNormalization :: String -> String
cdataNormalization = forall a. a -> a
id
otherNormalization :: String -> String
otherNormalization :: String -> String
otherNormalization = String -> String
reduceWSSequences forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
stringTrim forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
cdataNormalization
reduceWSSequences :: String -> String
reduceWSSequences :: String -> String
reduceWSSequences String
str = [String] -> String
unwords (String -> [String]
words String
str)