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 :: DatatypeLibraries
datatypeLibraries
= [ DatatypeLibrary
relaxDatatypeLib
, DatatypeLibrary
relaxDatatypeLib'
, DatatypeLibrary
mysqlDatatypeLib
, DatatypeLibrary
w3cDatatypeLib
]
datatypeEqual :: Uri -> DatatypeEqual
datatypeEqual :: Uri -> DatatypeEqual
datatypeEqual uri :: Uri
uri d :: Uri
d s1 :: Uri
s1 c1 :: Context
c1 s2 :: Uri
s2 c2 :: Context
c2
= if Uri -> [Uri] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Uri
uri ((DatatypeLibrary -> Uri) -> DatatypeLibraries -> [Uri]
forall a b. (a -> b) -> [a] -> [b]
map DatatypeLibrary -> Uri
forall a b. (a, b) -> a
fst DatatypeLibraries
datatypeLibraries)
then DatatypeEqual
dtEqFct Uri
d Uri
s1 Context
c1 Uri
s2 Context
c2
else Uri -> Maybe Uri
forall a. a -> Maybe a
Just ( "Unknown DatatypeLibrary " Uri -> Uri -> Uri
forall a. [a] -> [a] -> [a]
++ Uri -> Uri
forall a. Show a => a -> Uri
show Uri
uri )
where
DTC _ dtEqFct :: DatatypeEqual
dtEqFct _ = Maybe DatatypeCheck -> DatatypeCheck
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe DatatypeCheck -> DatatypeCheck)
-> Maybe DatatypeCheck -> DatatypeCheck
forall a b. (a -> b) -> a -> b
$ Uri -> DatatypeLibraries -> Maybe DatatypeCheck
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Uri
uri DatatypeLibraries
datatypeLibraries
datatypeAllows :: Uri -> DatatypeAllows
datatypeAllows :: Uri -> DatatypeAllows
datatypeAllows uri :: Uri
uri d :: Uri
d params :: ParamList
params s1 :: Uri
s1 c1 :: Context
c1
= if Uri -> [Uri] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Uri
uri ((DatatypeLibrary -> Uri) -> DatatypeLibraries -> [Uri]
forall a b. (a -> b) -> [a] -> [b]
map DatatypeLibrary -> Uri
forall a b. (a, b) -> a
fst DatatypeLibraries
datatypeLibraries)
then DatatypeAllows
dtAllowFct Uri
d ParamList
params Uri
s1 Context
c1
else Uri -> Maybe Uri
forall a. a -> Maybe a
Just ( "Unknown DatatypeLibrary " Uri -> Uri -> Uri
forall a. [a] -> [a] -> [a]
++ Uri -> Uri
forall a. Show a => a -> Uri
show Uri
uri )
where
DTC dtAllowFct :: DatatypeAllows
dtAllowFct _ _ = Maybe DatatypeCheck -> DatatypeCheck
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe DatatypeCheck -> DatatypeCheck)
-> Maybe DatatypeCheck -> DatatypeCheck
forall a b. (a -> b) -> a -> b
$ Uri -> DatatypeLibraries -> Maybe DatatypeCheck
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Uri
uri DatatypeLibraries
datatypeLibraries
relaxDatatypeLib :: DatatypeLibrary
relaxDatatypeLib :: DatatypeLibrary
relaxDatatypeLib = (Uri
relaxNamespace, DatatypeAllows
-> DatatypeEqual -> AllowedDatatypes -> DatatypeCheck
DTC DatatypeAllows
datatypeAllowsRelax DatatypeEqual
datatypeEqualRelax AllowedDatatypes
relaxDatatypes)
relaxDatatypeLib' :: DatatypeLibrary
relaxDatatypeLib' :: DatatypeLibrary
relaxDatatypeLib' = ("", DatatypeAllows
-> DatatypeEqual -> AllowedDatatypes -> DatatypeCheck
DTC DatatypeAllows
datatypeAllowsRelax DatatypeEqual
datatypeEqualRelax AllowedDatatypes
relaxDatatypes)
relaxDatatypes :: AllowedDatatypes
relaxDatatypes :: AllowedDatatypes
relaxDatatypes
= ((Uri, Uri -> Uri -> Bool) -> (Uri, [Uri]))
-> [(Uri, Uri -> Uri -> Bool)] -> AllowedDatatypes
forall a b. (a -> b) -> [a] -> [b]
map ( (\ x :: Uri
x -> (Uri
x, [])) (Uri -> (Uri, [Uri]))
-> ((Uri, Uri -> Uri -> Bool) -> Uri)
-> (Uri, Uri -> Uri -> Bool)
-> (Uri, [Uri])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Uri, Uri -> Uri -> Bool) -> Uri
forall a b. (a, b) -> a
fst ) [(Uri, Uri -> Uri -> Bool)]
relaxDatatypeTable
datatypeAllowsRelax :: DatatypeAllows
datatypeAllowsRelax :: DatatypeAllows
datatypeAllowsRelax d :: Uri
d p :: ParamList
p v :: Uri
v _
= Maybe Uri
-> ((Uri -> Uri -> Bool) -> Maybe Uri)
-> Maybe (Uri -> Uri -> Bool)
-> Maybe Uri
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Maybe Uri
notAllowed' (Uri -> Uri -> Bool) -> Maybe Uri
forall p a. p -> Maybe a
allowed (Maybe (Uri -> Uri -> Bool) -> Maybe Uri)
-> ([(Uri, Uri -> Uri -> Bool)] -> Maybe (Uri -> Uri -> Bool))
-> [(Uri, Uri -> Uri -> Bool)]
-> Maybe Uri
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Uri -> [(Uri, Uri -> Uri -> Bool)] -> Maybe (Uri -> Uri -> Bool)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Uri
d ([(Uri, Uri -> Uri -> Bool)] -> Maybe Uri)
-> [(Uri, Uri -> Uri -> Bool)] -> Maybe Uri
forall a b. (a -> b) -> a -> b
$ [(Uri, Uri -> Uri -> Bool)]
relaxDatatypeTable
where
notAllowed' :: Maybe Uri
notAllowed'
= Uri -> Maybe Uri
forall a. a -> Maybe a
Just (Uri -> Maybe Uri) -> Uri -> Maybe Uri
forall a b. (a -> b) -> a -> b
$ Uri -> Uri -> ParamList -> Uri -> Uri
errorMsgDataTypeNotAllowed Uri
relaxNamespace Uri
d ParamList
p Uri
v
allowed :: p -> Maybe a
allowed _
= Maybe a
forall a. Maybe a
Nothing
datatypeEqualRelax :: DatatypeEqual
datatypeEqualRelax :: DatatypeEqual
datatypeEqualRelax d :: Uri
d s1 :: Uri
s1 _ s2 :: Uri
s2 _
= Maybe Uri
-> ((Uri -> Uri -> Bool) -> Maybe Uri)
-> Maybe (Uri -> Uri -> Bool)
-> Maybe Uri
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Maybe Uri
notAllowed' (Uri -> Uri -> Bool) -> Maybe Uri
checkValues (Maybe (Uri -> Uri -> Bool) -> Maybe Uri)
-> ([(Uri, Uri -> Uri -> Bool)] -> Maybe (Uri -> Uri -> Bool))
-> [(Uri, Uri -> Uri -> Bool)]
-> Maybe Uri
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Uri -> [(Uri, Uri -> Uri -> Bool)] -> Maybe (Uri -> Uri -> Bool)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Uri
d ([(Uri, Uri -> Uri -> Bool)] -> Maybe Uri)
-> [(Uri, Uri -> Uri -> Bool)] -> Maybe Uri
forall a b. (a -> b) -> a -> b
$ [(Uri, Uri -> Uri -> Bool)]
relaxDatatypeTable
where
notAllowed' :: Maybe Uri
notAllowed'
= Uri -> Maybe Uri
forall a. a -> Maybe a
Just (Uri -> Maybe Uri) -> Uri -> Maybe Uri
forall a b. (a -> b) -> a -> b
$ Uri -> Uri -> Uri -> Uri -> Uri
errorMsgDataTypeNotAllowed2 Uri
relaxNamespace Uri
d Uri
s1 Uri
s2
checkValues :: (Uri -> Uri -> Bool) -> Maybe Uri
checkValues predicate :: Uri -> Uri -> Bool
predicate
= if Uri -> Uri -> Bool
predicate Uri
s1 Uri
s2
then Maybe Uri
forall a. Maybe a
Nothing
else Uri -> Maybe Uri
forall a. a -> Maybe a
Just (Uri -> Maybe Uri) -> Uri -> Maybe Uri
forall a b. (a -> b) -> a -> b
$ Uri -> Uri -> Uri -> Uri
errorMsgEqual Uri
d Uri
s1 Uri
s2
relaxDatatypeTable :: [(String, String -> String -> Bool)]
relaxDatatypeTable :: [(Uri, Uri -> Uri -> Bool)]
relaxDatatypeTable
= [ ("string", Uri -> Uri -> Bool
forall a. Eq a => a -> a -> Bool
(==))
, ("token", \ s1 :: Uri
s1 s2 :: Uri
s2 -> Uri -> Uri
normalizeWhitespace Uri
s1 Uri -> Uri -> Bool
forall a. Eq a => a -> a -> Bool
== Uri -> Uri
normalizeWhitespace Uri
s2 )
]