module Text.XML.HXT.RelaxNG.DataTypeLibraries
( datatypeLibraries
, datatypeEqual
, datatypeAllows
)
where
import Text.XML.HXT.DOM.Interface
( relaxNamespace
)
import Text.XML.HXT.RelaxNG.DataTypeLibUtils
import Text.XML.HXT.RelaxNG.DataTypeLibMysql
( mysqlDatatypeLib )
import Text.XML.HXT.RelaxNG.XMLSchema.DataTypeLibW3C
( w3cDatatypeLib )
import Data.Maybe
( fromJust )
datatypeLibraries :: DatatypeLibraries
datatypeLibraries
= [ relaxDatatypeLib
, relaxDatatypeLib'
, mysqlDatatypeLib
, w3cDatatypeLib
]
datatypeEqual :: Uri -> DatatypeEqual
datatypeEqual uri d s1 c1 s2 c2
= if elem uri (map fst datatypeLibraries)
then dtEqFct d s1 c1 s2 c2
else Just ( "Unknown DatatypeLibrary " ++ show uri )
where
DTC _ dtEqFct _ = fromJust $ lookup uri datatypeLibraries
datatypeAllows :: Uri -> DatatypeAllows
datatypeAllows uri d params s1 c1
= if elem uri (map fst datatypeLibraries)
then dtAllowFct d params s1 c1
else Just ( "Unknown DatatypeLibrary " ++ show uri )
where
DTC dtAllowFct _ _ = fromJust $ lookup uri datatypeLibraries
relaxDatatypeLib :: DatatypeLibrary
relaxDatatypeLib = (relaxNamespace, DTC datatypeAllowsRelax datatypeEqualRelax relaxDatatypes)
relaxDatatypeLib' :: DatatypeLibrary
relaxDatatypeLib' = ("", DTC datatypeAllowsRelax datatypeEqualRelax relaxDatatypes)
relaxDatatypes :: AllowedDatatypes
relaxDatatypes
= map ( (\ x -> (x, [])) . fst ) relaxDatatypeTable
datatypeAllowsRelax :: DatatypeAllows
datatypeAllowsRelax d p v _
= maybe notAllowed' allowed . lookup d $ relaxDatatypeTable
where
notAllowed'
= Just $ errorMsgDataTypeNotAllowed relaxNamespace d p v
allowed _
= Nothing
datatypeEqualRelax :: DatatypeEqual
datatypeEqualRelax d s1 _ s2 _
= maybe notAllowed' checkValues . lookup d $ relaxDatatypeTable
where
notAllowed'
= Just $ errorMsgDataTypeNotAllowed2 relaxNamespace d s1 s2
checkValues predicate
= if predicate s1 s2
then Nothing
else Just $ errorMsgEqual d s1 s2
relaxDatatypeTable :: [(String, String -> String -> Bool)]
relaxDatatypeTable
= [ ("string", (==))
, ("token", \ s1 s2 -> normalizeWhitespace s1 == normalizeWhitespace s2 )
]