hxt-8.5.4: src/Text/XML/HXT/DTDValidation/AttributeValueValidation.hs
-- ------------------------------------------------------------
{- |
Module : Text.XML.HXT.DTDValidation.TypeDefs
Copyright : Copyright (C) 2008 Uwe Schmidt
License : MIT
Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
Stability : experimental
Portability: portable
This module provides functions for validating attributes.
The main functions are:
- Check if the attribute value meets the lexical constraints of its type
- Normalization of an attribute value
-}
-- ------------------------------------------------------------
-- Special namings in source code:
--
-- - nd - XDTD node
--
-- - n - XTag node
--
module Text.XML.HXT.DTDValidation.AttributeValueValidation
( checkAttributeValue
, normalizeAttributeValue
)
where
import Text.XML.HXT.Parser.XmlParsec
( parseNMToken
, parseName
)
import Text.XML.HXT.DTDValidation.TypeDefs
-- ------------------------------------------------------------
-- |
-- Checks if the attribute value meets the lexical constraints of its type.
--
-- * 1.parameter dtdPart : the children of the @DOCTYPE@ node
--
-- - 2.parameter attrDecl : the declaration of the attribute from the DTD
--
-- - returns : a function which takes an element (XTag or XDTD ATTLIST),
-- checks if the attribute value meets the lexical constraints
-- of its type and returns a list of errors
checkAttributeValue :: XmlTrees -> XmlTree -> XmlArrow
checkAttributeValue dtdPart attrDecl
| isDTDAttlistNode attrDecl
= choiceA
[ isElem :-> ( checkAttrVal $< getAttrValue attrName )
, isDTDAttlist :-> ( checkAttrVal $< (getDTDAttrl >>^ dtd_default) )
, this :-> none
]
| otherwise
= none
where
al = getDTDAttributes attrDecl
attrName = dtd_value al
attrType = dtd_type al
checkAttrVal attrValue
= checkValue attrType dtdPart normalizedVal attrDecl
where
normalizedVal = normalizeAttributeValue (Just attrDecl) attrValue
-- |
-- Dispatches the attibute check by the attribute type.
--
-- * 1.parameter typ : the attribute type
--
-- - 2.parameter dtdPart : the children of the @DOCTYPE@ node
--
-- - 3.parameter attrValue : the normalized attribute value to be checked
--
-- - 4.parameter attrDecl : the declaration of the attribute from the DTD
--
-- - returns : a functions which takes an element (XTag or XDTD ATTLIST),
-- checks if the attribute value meets the lexical constraints
-- of its type and returns a list of errors
checkValue :: String -> XmlTrees -> String -> XmlTree -> XmlArrow
checkValue typ dtdPart attrValue attrDecl
| typ == k_cdata = none
| typ == k_enumeration = checkValueEnumeration attrDecl attrValue
| typ == k_entity = checkValueEntity dtdPart attrDecl attrValue
| typ == k_entities = checkValueEntities dtdPart attrDecl attrValue
| typ == k_id = checkValueId attrDecl attrValue
| typ == k_idref = checkValueIdref attrDecl attrValue
| typ == k_idrefs = checkValueIdrefs attrDecl attrValue
| typ == k_nmtoken = checkValueNmtoken attrDecl attrValue
| typ == k_nmtokens = checkValueNmtokens attrDecl attrValue
| typ == k_notation = checkValueEnumeration attrDecl attrValue
| otherwise = error ("Attribute type " ++ show typ ++ " unknown.")
-- |
-- Checks the value of Enumeration attribute types. (3.3.1 \/ p.27 in Spec)
--
-- * 1.parameter attrDecl : the declaration of the attribute from the DTD
--
-- - 2.parameter attrValue : the normalized attribute value to be checked
checkValueEnumeration :: XmlTree -> String -> XmlArrow
checkValueEnumeration attrDecl attrValue
| isDTDAttlistNode attrDecl
&&
attrValue `notElem` enumVals
= err ( "Attribute " ++ show (dtd_value al) ++ " for element " ++ show (dtd_name al) ++
" must have a value from list "++ show enumVals {- ++ " but has value " ++ show attrValue-} ++ ".")
| otherwise
= none
where
al = getDTDAttributes attrDecl
enumVals :: [String]
enumVals = map (dtd_name . getDTDAttributes) $ (runLA getChildren attrDecl)
-- |
-- Checks the value of ENTITY attribute types. (3.3.1 \/ p.26 in Spec)
--
-- * 1.parameter dtdPart : the children of the @DOCTYPE@ node, to get the
-- unparsed entity declarations
--
-- - 2.parameter attrDecl : the declaration of the attribute from the DTD
--
-- - 3.parameter attrValue : the normalized attribute value to be checked
checkValueEntity :: XmlTrees -> XmlTree -> String -> XmlArrow
checkValueEntity dtdPart attrDecl attrValue
| isDTDAttlistNode attrDecl
&&
attrValue `notElem` upEntities
= err ( "Entity " ++ show attrValue ++ " of attribute " ++ show (dtd_value al) ++
" for element " ++ show (dtd_name al) ++ " is not unparsed. " ++
"The following unparsed entities exist: " ++ show upEntities ++ ".")
| otherwise
= none
where
al = getDTDAttributes attrDecl
upEntities :: [String]
upEntities = map (dtd_name . getDTDAttributes) (isUnparsedEntity $$ dtdPart)
-- |
-- Checks the value of ENTITIES attribute types. (3.3.1 \/ p.26 in Spec)
--
-- * 1.parameter dtdPart : the children of the @DOCTYPE@ node, to get the
-- unparsed entity declarations
--
-- - 2.parameter attrDecl : the declaration of the attribute from the DTD
--
-- - 3.parameter attrValue : the normalized attribute value to be checked
checkValueEntities ::XmlTrees -> XmlTree -> String -> XmlArrow
checkValueEntities dtdPart attrDecl attrValue
| isDTDAttlistNode attrDecl
= if null valueList
then err ("Attribute " ++ show (dtd_value al) ++ " of element " ++
show (dtd_name al) ++ " must be one or more names.")
else catA . map (checkValueEntity dtdPart attrDecl) $ valueList
| otherwise
= none
where
al = getDTDAttributes attrDecl
valueList = words attrValue
-- |
-- Checks the value of NMTOKEN attribute types. (3.3.1 \/ p.26 in Spec)
--
-- * 1.parameter attrDecl : the declaration of the attribute from the DTD
--
-- - 2.parameter attrValue : the normalized attribute value to be checked
checkValueNmtoken :: XmlTree -> String -> XmlArrow
checkValueNmtoken attrDecl attrValue
| isDTDAttlistNode attrDecl
= constA attrValue >>> checkNmtoken
| otherwise
= none
where
al = getDTDAttributes attrDecl
checkNmtoken
= mkText >>> arrL (parseNMToken "")
>>>
isError
>>>
getErrorMsg
>>>
arr (\ s -> ( "Attribute value " ++ show attrValue ++ " of attribute " ++ show (dtd_value al) ++
" for element " ++ show (dtd_name al) ++ " must be a name token, "++ (lines s) !! 1 ++".") )
>>>
mkError c_err
-- |
-- Checks the value of NMTOKENS attribute types. (3.3.1 \/ p.26 in Spec)
--
-- * 1.parameter attrDecl : the declaration of the attribute from the DTD
--
-- - 2.parameter attrValue : the normalized attribute value to be checked
checkValueNmtokens :: XmlTree -> String -> XmlArrow
checkValueNmtokens attrDecl attrValue
| isDTDAttlistNode attrDecl
= if null valueList
then err ( "Attribute "++ show (dtd_value al) ++" of element " ++
show (dtd_name al) ++ " must be one or more name tokens.")
else catA . map (checkValueNmtoken attrDecl) $ valueList
| otherwise
= none
where
al = getDTDAttributes attrDecl
valueList = words attrValue
-- |
-- Checks the value of ID attribute types. (3.3.1 \/ p.25 in Spec)
--
-- * 1.parameter attrDecl : the declaration of the attribute from the DTD
--
-- - 2.parameter attrValue : the normalized attribute value to be checked
checkValueId :: XmlTree -> String -> XmlArrow
checkValueId attrDecl attrValue
= checkForName "Attribute value" attrDecl attrValue
-- |
-- Checks the value of IDREF attribute types. (3.3.1 \/ p.26 in Spec)
--
-- * 1.parameter attrDecl : the declaration of the attribute from the DTD
--
-- - 2.parameter attrValue : the normalized attribute value to be checked
checkValueIdref :: XmlTree -> String -> XmlArrow
checkValueIdref attrDecl attrValue
= checkForName "Attribute value" attrDecl attrValue
-- |
-- Checks the value of IDREFS attribute types. (3.3.1 \/ p.26 in Spec)
--
-- * 1.parameter attrDecl : the declaration of the attribute from the DTD
--
-- - 2.parameter attrValue : the normalized attribute value to be checked
checkValueIdrefs :: XmlTree -> String -> XmlArrow
checkValueIdrefs attrDecl attrValue
= catA . map (checkValueIdref attrDecl) . words $ attrValue
-- -----------------------------------------------------------------------------
-- General helper functions for checking attribute values
--
-- |
-- Checks if the value of an attribute is a name.
--
-- * 1.parameter msg : error message, should be "Entity" or "Attribute value"
--
-- - 2.parameter attrDecl : the declaration of the attribute from the DTD
--
-- - 3.parameter attrValue : the normalized attribute value to be checked
checkForName :: String -> XmlTree -> String -> XmlArrow
checkForName msg attrDecl attrValue
| isDTDAttlistNode attrDecl
= constA attrValue >>> checkName
| otherwise
= none
where
al = getDTDAttributes attrDecl
checkName
= mkText >>> arrL (parseName "")
>>>
isError
>>>
getErrorMsg
>>>
arr (\s -> ( msg ++ " " ++ show attrValue ++" of attribute " ++ show (dtd_value al) ++
" for element "++ show (dtd_name al) ++" must be a name, " ++ (lines s) !! 1 ++ ".") )
>>>
mkError c_err
-- -----------------------------------------------------------------------------
-- |
-- Normalizes an attribute value with respect to its type. (3.3.3 \/ p.29 in Spec)
--
-- * 1.parameter attrDecl : the declaration of the attribute from the DTD. Expected
-- is a list. If the list is empty, no declaration exists.
--
-- - 2.parameter value : the attribute value to be normalized
--
-- - returns : the normalized value
--
normalizeAttributeValue :: Maybe XmlTree -> String -> String
normalizeAttributeValue (Just attrDecl) value
= normalizeAttribute attrType
where
al = getDTDAttributes attrDecl
attrType = dtd_type al
normalizeAttribute :: String -> String
normalizeAttribute typ
| typ == k_cdata = cdataNormalization value
| otherwise = otherNormalization value
-- Attribute not declared in DTD, normalization as CDATA
normalizeAttributeValue Nothing value
= cdataNormalization value
-- ------------------------------------------------------------
-- Helper functions for normalization
-- |
-- Normalization of CDATA attribute values.
-- is already done when parsing
-- during entity substituion for attribute values
cdataNormalization :: String -> String
cdataNormalization = id
-- | Normalization of attribute values other than CDATA.
otherNormalization :: String -> String
otherNormalization = reduceWSSequences . stringTrim . cdataNormalization
-- | Reduce whitespace sequences to a single whitespace.
reduceWSSequences :: String -> String
reduceWSSequences str = unwords (words str)
-- ------------------------------------------------------------