module Text.XML.HXT.RelaxNG.XmlSchema.DataTypeLibW3C
( w3cNS
, w3cDatatypeLib
, xsd_string
, xsd_normalizedString
, xsd_token
, xsd_language
, xsd_NMTOKEN
, xsd_NMTOKENS
, xsd_Name
, xsd_NCName
, xsd_ID
, xsd_IDREF
, xsd_IDREFS
, xsd_ENTITY
, xsd_ENTITIES
, xsd_anyURI
, xsd_QName
, xsd_NOTATION
, xsd_hexBinary
, xsd_base64Binary
, xsd_decimal
, xsd_length
, xsd_maxLength
, xsd_minLength
, xsd_maxExclusive
, xsd_minExclusive
, xsd_maxInclusive
, xsd_minInclusive
, xsd_totalDigits
, xsd_fractionDigits
, xsd_pattern
, xsd_enumeration
)
where
import Data.Maybe
import Data.Ratio
import Network.URI ( isURIReference )
import Text.XML.HXT.DOM.QualifiedName ( isWellformedQualifiedName
, isNCName
)
import Text.XML.HXT.RelaxNG.DataTypeLibUtils
import Text.XML.HXT.RelaxNG.XmlSchema.Regex ( Regex
, matchWithRE
)
import Text.XML.HXT.RelaxNG.XmlSchema.RegexParser
( parseRegex
)
w3cNS :: String
w3cNS = "http://www.w3.org/2001/XMLSchema-datatypes"
xsd_string
, xsd_normalizedString
, xsd_token
, xsd_language
, xsd_NMTOKEN
, xsd_NMTOKENS
, xsd_Name
, xsd_NCName
, xsd_ID
, xsd_IDREF
, xsd_IDREFS
, xsd_ENTITY
, xsd_ENTITIES
, xsd_anyURI
, xsd_QName
, xsd_NOTATION
, xsd_hexBinary
, xsd_base64Binary
, xsd_decimal
, xsd_integer
, xsd_nonPositiveInteger
, xsd_negativeInteger
, xsd_nonNegativeInteger
, xsd_positiveInteger
, xsd_long
, xsd_int
, xsd_short
, xsd_byte
, xsd_unsignedLong
, xsd_unsignedInt
, xsd_unsignedShort
, xsd_unsignedByte :: String
xsd_string = "string"
xsd_normalizedString = "normalizedString"
xsd_token = "token"
xsd_language = "language"
xsd_NMTOKEN = "NMTOKEN"
xsd_NMTOKENS = "NMTOKENS"
xsd_Name = "Name"
xsd_NCName = "NCName"
xsd_ID = "ID"
xsd_IDREF = "IDREF"
xsd_IDREFS = "IDREFS"
xsd_ENTITY = "ENTITY"
xsd_ENTITIES = "ENTITIES"
xsd_anyURI = "anyURI"
xsd_QName = "QName"
xsd_NOTATION = "NOTATION"
xsd_hexBinary = "hexBinary"
xsd_base64Binary = "base64Binary"
xsd_decimal = "decimal"
xsd_integer = "integer"
xsd_nonPositiveInteger = "nonPositiveInteger"
xsd_negativeInteger = "negativeInteger"
xsd_nonNegativeInteger = "nonNegativeInteger"
xsd_positiveInteger = "positiveInteger"
xsd_long = "long"
xsd_int = "int"
xsd_short = "short"
xsd_byte = "byte"
xsd_unsignedLong = "unsignedLong"
xsd_unsignedInt = "unsignedInt"
xsd_unsignedShort = "unsignedShort"
xsd_unsignedByte = "unsignedByte"
xsd_length
, xsd_maxLength
, xsd_minLength
, xsd_maxExclusive
, xsd_minExclusive
, xsd_maxInclusive
, xsd_minInclusive
, xsd_totalDigits
, xsd_fractionDigits
, xsd_pattern
, xsd_enumeration :: String
xsd_length = rng_length
xsd_maxLength = rng_maxLength
xsd_minLength = rng_minLength
xsd_maxExclusive = rng_maxExclusive
xsd_minExclusive = rng_minExclusive
xsd_maxInclusive = rng_maxInclusive
xsd_minInclusive = rng_minInclusive
xsd_totalDigits = "totalDigits"
xsd_fractionDigits = "fractionDigits"
xsd_pattern = "pattern"
xsd_enumeration = "enumeration"
w3cDatatypeLib :: DatatypeLibrary
w3cDatatypeLib = (w3cNS, DTC datatypeAllowsW3C datatypeEqualW3C w3cDatatypes)
w3cDatatypes :: AllowedDatatypes
w3cDatatypes = [ (xsd_string, stringParams)
, (xsd_normalizedString, stringParams)
, (xsd_token, stringParams)
, (xsd_language, stringParams)
, (xsd_NMTOKEN, stringParams)
, (xsd_NMTOKENS, listParams )
, (xsd_Name, stringParams)
, (xsd_NCName, stringParams)
, (xsd_ID, stringParams)
, (xsd_IDREF, stringParams)
, (xsd_IDREFS, listParams )
, (xsd_ENTITY, stringParams)
, (xsd_ENTITIES, listParams )
, (xsd_anyURI, stringParams)
, (xsd_QName, stringParams)
, (xsd_NOTATION, stringParams)
, (xsd_hexBinary, stringParams)
, (xsd_base64Binary, stringParams)
, (xsd_decimal, decimalParams)
, (xsd_integer, integerParams)
, (xsd_nonPositiveInteger, integerParams)
, (xsd_negativeInteger, integerParams)
, (xsd_nonNegativeInteger, integerParams)
, (xsd_positiveInteger, integerParams)
, (xsd_long, integerParams)
, (xsd_int, integerParams)
, (xsd_short, integerParams)
, (xsd_byte, integerParams)
, (xsd_unsignedLong, integerParams)
, (xsd_unsignedInt, integerParams)
, (xsd_unsignedShort, integerParams)
, (xsd_unsignedByte, integerParams)
]
stringParams :: AllowedParams
stringParams = xsd_pattern : map fst fctTableString
patternValid :: ParamList -> CheckString
patternValid params
= foldr (>>>) ok . map paramPatternValid $ params
where
paramPatternValid (pn, pv)
| pn == xsd_pattern = assert (patParamValid pv) (errorMsgParam pn pv)
| otherwise = ok
patParamValid :: String -> String -> Bool
patParamValid regex a
= case parseRegex regex of
(Left _ ) -> False
(Right ex) -> isNothing . matchWithRE ex $ a
decimalParams :: AllowedParams
decimalParams = xsd_pattern : map fst fctTableDecimal
fctTableDecimal :: [(String, String -> Rational -> Bool)]
fctTableDecimal
= [ (xsd_maxExclusive, cvd (>))
, (xsd_minExclusive, cvd (<))
, (xsd_maxInclusive, cvd (>=))
, (xsd_minInclusive, cvd (<=))
, (xsd_totalDigits, cvi (\ l v -> totalDigits v == l))
, (xsd_fractionDigits, cvi (\ l v -> fractionDigits v == l))
]
where
cvd :: (Rational -> Rational -> Bool) -> (String -> Rational -> Bool)
cvd op = \ x y -> isDecimal x && readDecimal x `op` y
cvi :: (Int -> Rational -> Bool) -> (String -> Rational -> Bool)
cvi op = \ x y -> isNumber x && read x `op` y
decimalValid :: ParamList -> CheckA Rational Rational
decimalValid params
= foldr (>>>) ok . map paramDecimalValid $ params
where
paramDecimalValid (pn, pv)
= assert
((fromMaybe (const . const $ True) . lookup pn $ fctTableDecimal) pv)
(errorMsgParam pn pv . showDecimal)
integerParams :: AllowedParams
integerParams = xsd_pattern : map fst fctTableInteger
fctTableInteger :: [(String, String -> Integer -> Bool)]
fctTableInteger
= [ (xsd_maxExclusive, cvi (>))
, (xsd_minExclusive, cvi (<))
, (xsd_maxInclusive, cvi (>=))
, (xsd_minInclusive, cvi (<=))
, (xsd_totalDigits, cvi (\ l v -> totalD v == toInteger l))
]
where
cvi :: (Integer -> Integer -> Bool) -> (String -> Integer -> Bool)
cvi op = \ x y -> isNumber x && read x `op` y
totalD i
| i < 0 = totalD (0i)
| otherwise = toInteger . length . show $ i
integerValid :: DatatypeName -> ParamList -> CheckA Integer Integer
integerValid datatype params
= assertInRange
>>>
(foldr (>>>) ok . map paramIntegerValid $ params)
where
assertInRange :: CheckA Integer Integer
assertInRange
= assert
(fromMaybe (const True) . lookup datatype $ integerRangeTable)
(\ v -> ( "Datatype " ++ show datatype ++
" with value = " ++ show v ++
" not in integer value range"
)
)
paramIntegerValid (pn, pv)
= assert
((fromMaybe (const . const $ True) . lookup pn $ fctTableInteger) pv)
(errorMsgParam pn pv . show)
integerRangeTable :: [(String, Integer -> Bool)]
integerRangeTable = [ (xsd_integer, const True)
, (xsd_nonPositiveInteger, (<=0) )
, (xsd_negativeInteger, ( <0) )
, (xsd_nonNegativeInteger, (>=0) )
, (xsd_positiveInteger, ( >0) )
, (xsd_long, inR 9223372036854775808)
, (xsd_int, inR 2147483648)
, (xsd_short, inR 32768)
, (xsd_byte, inR 128)
, (xsd_unsignedLong, inP 18446744073709551616)
, (xsd_unsignedInt, inP 4294967296)
, (xsd_unsignedShort, inP 65536)
, (xsd_unsignedByte, inP 256)
]
where
inR b i = (0 b) <= i && i < b
inP b i = 0 <= i && i < b
listParams :: AllowedParams
listParams = xsd_pattern : map fst fctTableList
listValid :: DatatypeName -> ParamList -> CheckString
listValid d = stringValidFT fctTableList d 0 (1)
isNameList :: (String -> Bool) -> String -> Bool
isNameList p w
= not (null ts) && all p ts
where
ts = words w
rex :: String -> Regex
rex = either undefined id . parseRegex
isRex :: Regex -> String -> Bool
isRex ex = isNothing . matchWithRE ex
rexLanguage
, rexHexBinary
, rexBase64Binary
, rexDecimal
, rexInteger :: Regex
rexLanguage = rex "[A-Za-z]{1,8}(-[A-Za-z]{1,8})*"
rexHexBinary = rex "([A-Fa-f0-9]{2})*"
rexBase64Binary = rex $
"(" ++ b64 ++ "{4})*((" ++ b64 ++ "{2}==)|(" ++ b64 ++ "{3}=)|)"
where
b64 = "[A-Za-z0-9+/]"
rexDecimal = rex "(\\+|-)?(([0-9]+(\\.[0-9]*)?)|(\\.[0-9]+))"
rexInteger = rex "(\\+|-)?[0-9]+"
isLanguage
, isHexBinary
, isBase64Binary
, isDecimal
, isInteger :: String -> Bool
isLanguage = isRex rexLanguage
isHexBinary = isRex rexHexBinary
isBase64Binary = isRex rexBase64Binary
isDecimal = isRex rexDecimal
isInteger = isRex rexInteger
normBase64 :: String -> String
normBase64 = filter isB64
where
isB64 c = ( 'A' <= c && c <= 'Z')
||
( 'a' <= c && c <= 'z')
||
( '0' <= c && c <= '9')
||
c == '+'
||
c == '/'
||
c == '='
readDecimal
, readDecimal' :: String -> Rational
readDecimal ('+':s) = readDecimal' s
readDecimal ('-':s) = negate (readDecimal' s)
readDecimal s = readDecimal' s
readDecimal' s
| f == 0 = (n % 1)
| otherwise = (n % 1) + (f % (10 ^ (toInteger (length fs))))
where
(ns, fs') = span (/= '.') s
fs = drop 1 fs'
f :: Integer
f | null fs = 0
| otherwise = read fs
n :: Integer
n | null ns = 0
| otherwise = read ns
totalDigits
, totalDigits'
, fractionDigits :: Rational -> Int
totalDigits r
| r == 0 = 0
| r < 0 = totalDigits' . negate $ r
| otherwise = totalDigits' $ r
totalDigits' r
| denominator r == 1 = length . show . numerator $ r
| r < (1%1) = (\ x -> x1) . totalDigits' . (+ (1%1)) $ r
| otherwise = totalDigits' . (* (10 % 1)) $ r
fractionDigits r
| denominator r == 1 = 0
| otherwise = (+1) . fractionDigits . (* (10 % 1)) $ r
showDecimal
, showDecimal' :: Rational -> String
showDecimal d
| d < 0 = ('-':) . showDecimal' . negate $ d
| d < 1 = drop 1 . showDecimal' . (+ (1%1)) $ d
| otherwise = showDecimal' $ d
showDecimal' d
| denominator d == 1 = show . numerator $ d
| otherwise = times10 0 $ d
where
times10 i' d'
| denominator d' == 1 = let
(x, y) = splitAt i' . reverse . show . numerator $ d'
in
reverse y ++ "." ++ reverse x
| otherwise = times10 (i' + 1) (d' * (10 % 1))
datatypeAllowsW3C :: DatatypeAllows
datatypeAllowsW3C d params value _
= performCheck check value
where
validString normFct
= validPattern
>>>
arr normFct
>>>
validLength
validNormString
= validString normalizeWhitespace
validPattern
= patternValid params
validLength
= stringValid d 0 (1) params
validList
= validPattern
>>>
arr normalizeWhitespace
>>>
validListLength
validListLength
= listValid d params
validName isN
= assertW3C isN
validNCName
= validNormString >>> validName isNCName
validQName
= validNormString >>> validName isWellformedQualifiedName
validDecimal
= arr normalizeWhitespace
>>>
assertW3C isDecimal
>>>
checkWith readDecimal (decimalValid params)
validInteger inRange
= validPattern
>>>
arr normalizeWhitespace
>>>
assertW3C isInteger
>>>
checkWith read (integerValid inRange params)
check :: CheckString
check = fromMaybe notFound . lookup d $ checks
notFound = failure $ errorMsgDataTypeNotAllowed w3cNS d params
checks :: [(String, CheckA String String)]
checks = [ (xsd_string, validString id)
, (xsd_normalizedString, validString normalizeBlanks)
, (xsd_token, validNormString)
, (xsd_language, validNormString >>> assertW3C isLanguage)
, (xsd_NMTOKEN, validNormString >>> validName isNmtoken)
, (xsd_NMTOKENS, validList >>> validName (isNameList isNmtoken))
, (xsd_Name, validNormString >>> validName isName)
, (xsd_NCName, validNCName)
, (xsd_ID, validNCName)
, (xsd_IDREF, validNCName)
, (xsd_IDREFS, validList >>> validName (isNameList isNCName))
, (xsd_ENTITY, validNCName)
, (xsd_ENTITIES, validList >>> validName (isNameList isNCName))
, (xsd_anyURI, validName isURIReference >>> validString escapeURI)
, (xsd_QName, validQName)
, (xsd_NOTATION, validQName)
, (xsd_hexBinary, validString id >>> assertW3C isHexBinary)
, (xsd_base64Binary, validString normBase64 >>> assertW3C isBase64Binary)
, (xsd_decimal, validPattern >>> validDecimal)
, (xsd_integer, validInteger xsd_integer)
, (xsd_nonPositiveInteger, validInteger xsd_nonPositiveInteger)
, (xsd_negativeInteger, validInteger xsd_negativeInteger)
, (xsd_nonNegativeInteger, validInteger xsd_nonNegativeInteger)
, (xsd_positiveInteger, validInteger xsd_positiveInteger)
, (xsd_long, validInteger xsd_long)
, (xsd_int, validInteger xsd_int)
, (xsd_short, validInteger xsd_short)
, (xsd_byte, validInteger xsd_byte)
, (xsd_unsignedLong, validInteger xsd_unsignedLong)
, (xsd_unsignedInt, validInteger xsd_unsignedInt)
, (xsd_unsignedShort, validInteger xsd_unsignedShort)
, (xsd_unsignedByte, validInteger xsd_unsignedByte)
]
assertW3C p = assert p errW3C
errW3C = errorMsgDataLibQName w3cNS d
datatypeEqualW3C :: DatatypeEqual
datatypeEqualW3C d s1 _ s2 _
= performCheck check (s1, s2)
where
check :: CheckA (String, String) (String, String)
check = maybe notFound found . lookup d $ norm
notFound = failure $ const (errorMsgDataTypeNotAllowed0 w3cNS d)
found nf = arr (\ (x1, x2) -> (nf x1, nf x2))
>>>
assert (uncurry (==)) (uncurry $ errorMsgEqual d)
norm = [ (xsd_string, id )
, (xsd_normalizedString, normalizeBlanks )
, (xsd_token, normalizeWhitespace )
, (xsd_language, normalizeWhitespace )
, (xsd_NMTOKEN, normalizeWhitespace )
, (xsd_NMTOKENS, normalizeWhitespace )
, (xsd_Name, normalizeWhitespace )
, (xsd_NCName, normalizeWhitespace )
, (xsd_ID, normalizeWhitespace )
, (xsd_IDREF, normalizeWhitespace )
, (xsd_IDREFS, normalizeWhitespace )
, (xsd_ENTITY, normalizeWhitespace )
, (xsd_ENTITIES, normalizeWhitespace )
, (xsd_anyURI, escapeURI . normalizeWhitespace )
, (xsd_QName, normalizeWhitespace )
, (xsd_NOTATION, normalizeWhitespace )
, (xsd_hexBinary, id )
, (xsd_base64Binary, normBase64 )
, (xsd_decimal, show . readDecimal . normalizeWhitespace )
]