module Text.XML.HXT.RelaxNG.DataTypeLibUtils
( errorMsgEqual
, errorMsgDataTypeNotAllowed
, errorMsgDataTypeNotAllowed0
, errorMsgDataTypeNotAllowed2
, errorMsgDataLibQName
, errorMsgParam
, rng_length
, rng_maxLength
, rng_minLength
,rng_maxExclusive
, rng_minExclusive
, rng_maxInclusive
, rng_minInclusive
, module Control.Arrow
, module Text.XML.HXT.DOM.Util
, module Text.XML.HXT.RelaxNG.Utils
, module Text.XML.HXT.RelaxNG.DataTypes
, FunctionTable
, stringValidFT
, fctTableString
, fctTableList
, stringValid
, numberValid
, numParamValid
, CheckA
, CheckString
, CheckInteger
, performCheck
, ok
, failure
, assert
, assertMaybe
, checkWith
)
where
import Prelude hiding (id, (.))
import Control.Category
import Control.Arrow
import Data.Maybe
import Text.XML.HXT.DOM.Util
import Text.XML.HXT.RelaxNG.DataTypes
import Text.XML.HXT.RelaxNG.Utils
newtype CheckA a b = C { runCheck :: a -> Either String b }
instance Category CheckA where
id = C $ Right
f2 . f1 = C $
\ x -> case runCheck f1 x of
Right y -> runCheck f2 y
Left e -> Left e
instance Arrow CheckA where
arr f = C ( Right . f )
first f1 = C $
\ ~(x1, x2) -> case runCheck f1 x1 of
Right y1 -> Right (y1, x2)
Left e -> Left e
second f2 = C $
\ ~(x1, x2) -> case runCheck f2 x2 of
Right y2 -> Right (x1, y2)
Left e -> Left e
instance ArrowZero CheckA where
zeroArrow = C $ const (Left "")
instance ArrowPlus CheckA where
f1 <+> f2 = C $
\ x -> case runCheck f1 x of
Right y1 -> Right y1
Left e1 -> case runCheck f2 x of
Right y2 -> Right y2
Left e2 -> Left ( if null e1
then e2
else
if null e2
then e1
else e1 ++ " or " ++ e2
)
type CheckString = CheckA String String
type CheckInteger = CheckA Integer Integer
performCheck :: CheckA a b -> a -> Maybe String
performCheck c = either Just (const Nothing) . runCheck c
failure :: (a -> String) -> CheckA a b
failure msg = C (Left . msg)
ok :: CheckA a a
ok = arr id
assert :: (a -> Bool) -> (a -> String) -> CheckA a a
assert p msg = C $ \ x -> if p x then Right x else Left (msg x)
assertMaybe :: (a -> Maybe b) -> (a -> String) -> CheckA a b
assertMaybe f msg
= C $ \ x -> case f x of
Nothing -> Left (msg x)
Just y -> Right y
checkWith :: (a -> b) -> CheckA b c -> CheckA a a
checkWith f c = C $
\ x -> case runCheck c (f x) of
Right _ -> Right x
Left e -> Left e
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)]
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 (>=)))
]
fctTableList :: FunctionTable
fctTableList
= [ (rng_length, (listParamValid (==)))
, (rng_maxLength, (listParamValid (<=)))
, (rng_minLength, (listParamValid (>=)))
]
numParamValid :: (Integer -> Integer -> Bool) -> String -> String -> Bool
numParamValid fct a b
= isNumber b
&&
( toInteger (length a) `fct` (read b) )
listParamValid :: (Integer -> Integer -> Bool) -> String -> String -> Bool
listParamValid fct a b
= isNumber b
&&
( toInteger (length . words $ a) `fct` (read b) )
stringValid :: DatatypeName -> Integer -> Integer -> ParamList -> CheckString
stringValid = stringValidFT fctTableString
stringValidFT :: FunctionTable -> DatatypeName -> Integer -> Integer -> ParamList -> CheckString
stringValidFT ft datatype lowerBound upperBound params
= assert boundsOK boundsErr
>>>
paramsStringValid params
where
boundsOK v
= ( (lowerBound == 0)
||
(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) -> CheckString
paramStringValid (pn, pv)
= assert paramOK (errorMsgParam pn pv)
where
paramOK v = paramFct pn v pv
paramFct n = fromMaybe (const . const $ True) $ lookup n ft
paramsStringValid :: ParamList -> CheckString
paramsStringValid
= foldr (>>>) ok . map paramStringValid
numberValid :: DatatypeName -> Integer -> Integer -> ParamList -> CheckString
numberValid datatype lowerBound upperBound params
= assert isNumber numErr
>>>
checkWith read ( assert inRange rangeErr
>>>
paramsNumValid params
)
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 -> CheckInteger
paramsNumValid
= foldr (>>>) ok . map paramNumValid
paramNumValid :: (LocalName, String) -> CheckInteger
paramNumValid (pn, pv)
= assert paramOK (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 l t p v
= ( "Datatype " ++ show t ++ " with parameter(s) " ++
formatStringListPairs p ++ " and value = " ++ show v ++
" not allowed for DatatypeLibrary " ++ show l
)
errorMsgDataTypeNotAllowed0 :: String -> String -> String
errorMsgDataTypeNotAllowed0 l t
= ( "Datatype " ++ show t ++
" not allowed for DatatypeLibrary " ++ show l
)
errorMsgDataTypeNotAllowed2 :: String -> String -> String -> String -> String
errorMsgDataTypeNotAllowed2 l t v1 v2
= ( "Datatype " ++ show t ++
" with values = " ++ show v1 ++
" and " ++ show v2 ++
" not allowed for DatatypeLibrary " ++ show l
)
errorMsgDataLibQName :: String -> String -> String -> String
errorMsgDataLibQName l n v
= show v ++ " is not a valid " ++ n ++ " for DatatypeLibrary " ++ l