module Text.XML.HXT.RelaxNG.DataTypeLibUtils
( errorMsgEqual
, errorMsgDataTypeNotAllowed
, errorMsgDataTypeNotAllowed0
, errorMsgDataTypeNotAllowed2
, errorMsgDataLibQName
, rng_length
, rng_maxLength
, rng_minLength
,rng_maxExclusive
, rng_minExclusive
, rng_maxInclusive
, rng_minInclusive
, module Text.XML.HXT.DOM.Util
, module Text.XML.HXT.RelaxNG.Utils
, module Text.XML.HXT.RelaxNG.DataTypes
, alwaysOK
, alwaysErr
, orErr
, andCheck
, withVal
, stringValid
, numberValid
)
where
import Text.XML.HXT.DOM.Util
import Text.XML.HXT.RelaxNG.DataTypes
import Text.XML.HXT.RelaxNG.Utils
import Data.Maybe
( fromJust )
rng_length, rng_maxLength, rng_minLength
,rng_maxExclusive, rng_minExclusive, rng_maxInclusive, rng_minInclusive :: String
rng_length = "length"
rng_maxLength = "maxLength"
rng_minLength = "minLength"
rng_maxExclusive = "maxExclusive"
rng_minExclusive = "minExclusive"
rng_maxInclusive = "maxInclusive"
rng_minInclusive = "minInclusive"
type FunctionTable = [(String, String -> String -> Bool)]
type Check a = a -> Maybe String
fctTableNum :: (Ord a, Num a) => [(String, a -> a -> Bool)]
fctTableNum
= [ (rng_maxExclusive, (<))
, (rng_minExclusive, (>))
, (rng_maxInclusive, (<=))
, (rng_minInclusive, (>=))
]
fctTableString :: FunctionTable
fctTableString
= [ (rng_length, (numParamValid (==)))
, (rng_maxLength, (numParamValid (<=)))
, (rng_minLength, (numParamValid (>=)))
]
numParamValid :: (Integer -> Integer -> Bool) -> String -> String -> Bool
numParamValid fct a b
= isNumber b
&&
( toInteger (length a) `fct` (read b) )
alwaysOK :: Check a
alwaysOK _ = Nothing
alwaysErr :: (a -> String) -> Check a
alwaysErr msg = Just . msg
orErr :: (a -> Bool) -> (a -> String) -> Check a
orErr p msg s
| p s = Nothing
| otherwise = Just $ msg s
andCheck :: Check a -> Check a -> Check a
andCheck c1 c2 s
= res (c1 s)
where
res Nothing = c2 s
res r1 = r1
withVal :: Check a -> (b -> a) -> Check b
withVal c1 f v
= c1 (f v)
stringValid :: DatatypeName -> Integer -> Integer -> ParamList -> Check String
stringValid datatype lowerBound upperBound params
= boundsOK `orErr` boundsErr
`andCheck`
paramsStringValid params
where
boundsOK v
= (toInteger (length v) >= lowerBound)
&&
((upperBound == (1)) || (toInteger (length v) <= upperBound))
boundsErr v
= "Length of " ++ v
++ " (" ++ (show $ length v) ++ " chars) out of range: "
++ show lowerBound ++ " .. " ++ show upperBound
++ " for datatype " ++ datatype
paramStringValid :: (LocalName, String) -> (Check String)
paramStringValid (pn, pv)
= paramOK `orErr` errorMsgParam pn pv
where
paramOK v = paramFct pn v pv
paramFct n = fromJust $ lookup n fctTableString
paramsStringValid :: ParamList -> (Check String)
paramsStringValid
= foldr andCheck alwaysOK . map paramStringValid
numberValid :: DatatypeName -> Integer -> Integer -> ParamList -> Check String
numberValid datatype lowerBound upperBound params
= (isNumber `orErr` numErr)
`andCheck`
( ( (inRange `orErr` rangeErr)
`andCheck`
paramsNumValid params
)
`withVal` read
)
where
inRange :: Integer -> Bool
inRange x
= x >= lowerBound
&&
x <= upperBound
rangeErr v
= "Value = " ++ show v ++ " out of range: "
++ show lowerBound ++ " .. " ++ show upperBound
++ " for datatype " ++ datatype
numErr v
= "Value = " ++ v ++ " is not a number"
paramsNumValid :: ParamList -> Check Integer
paramsNumValid
= foldr andCheck alwaysOK . map paramNumValid
paramNumValid :: (LocalName, String) -> Check Integer
paramNumValid (pn, pv)
= paramOK `orErr` (errorMsgParam pn pv . show)
where
paramOK v = isNumber pv
&&
paramFct pn v (read pv)
paramFct n = fromJust $ lookup n fctTableNum
errorMsgParam :: LocalName -> String -> String -> String
errorMsgParam pn pv v
= ( "Parameter restriction: \""
++ pn ++ " = " ++ pv
++ "\" does not hold for value = \"" ++ v ++ "\""
)
errorMsgEqual :: DatatypeName -> String -> String -> String
errorMsgEqual d s1 s2
= ( "Datatype" ++ show d ++
" with value = " ++ show s1 ++
" expected, but value = " ++ show s2 ++ " found"
)
errorMsgDataTypeNotAllowed :: String -> [(String, String)] -> String -> String -> String
errorMsgDataTypeNotAllowed t p v l
= ( "Datatype " ++ show t ++ " with parameter(s) " ++
formatStringListPairs p ++ " and value = " ++ show v ++
" not allowed for DatatypeLibrary " ++ show l
)
errorMsgDataTypeNotAllowed0 :: String -> String -> String
errorMsgDataTypeNotAllowed0 t l
= ( "Datatype " ++ show t ++
" not allowed for DatatypeLibrary " ++ show l
)
errorMsgDataTypeNotAllowed2 :: String -> String -> String -> String -> String
errorMsgDataTypeNotAllowed2 t v1 v2 l
= ( "Datatype " ++ show t ++
" with values = " ++ show v1 ++
" and " ++ show v2 ++
" not allowed for DatatypeLibrary " ++ show l
)
errorMsgDataLibQName :: String -> String -> String -> String
errorMsgDataLibQName v n l
= show v ++ " is not a valid " ++ n ++ " for DatatypeLibrary " ++ l