-- | This modul exports the list of supported datatype libraries.
-- It also exports the main functions to validate an XML instance value
-- with respect to a datatype.

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 )

-- ------------------------------------------------------------


-- | List of all supported datatype libraries which can be
-- used within the Relax NG validator modul.

datatypeLibraries :: DatatypeLibraries
datatypeLibraries :: DatatypeLibraries
datatypeLibraries
    = [ DatatypeLibrary
relaxDatatypeLib
      , DatatypeLibrary
relaxDatatypeLib'
      , DatatypeLibrary
mysqlDatatypeLib
      , DatatypeLibrary
w3cDatatypeLib
      ]


{- |
Tests whether a XML instance value matches a value-pattern.

The following tests are performed:

   * 1. :  does the uri exist in the list of supported datatype libraries

   - 2. :  does the library support the datatype

   - 3. :  does the XML instance value match the value-pattern

The hard work is done by the specialized 'DatatypeEqual' function
(see also: 'DatatypeCheck') of the datatype library.
-}

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

{- |
Tests whether a XML instance value matches a data-pattern.

The following tests are performed:

   * 1. :  does the uri exist in the list of supported datatype libraries

   - 2. :  does the library support the datatype

   - 3. :  does the XML instance value match the data-pattern

   - 4. :  does the XML instance value match all params

The hard work is done by the specialized 'DatatypeAllows' function
(see also: 'DatatypeCheck') of the datatype library.

-}

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


-- --------------------------------------------------------------------------------------
-- Relax NG build in datatype library

relaxDatatypeLib        :: DatatypeLibrary
relaxDatatypeLib :: DatatypeLibrary
relaxDatatypeLib        = (Uri
relaxNamespace, DatatypeAllows
-> DatatypeEqual -> AllowedDatatypes -> DatatypeCheck
DTC DatatypeAllows
datatypeAllowsRelax DatatypeEqual
datatypeEqualRelax AllowedDatatypes
relaxDatatypes)

-- | if there is no datatype uri, the built in datatype library is used
relaxDatatypeLib'       :: DatatypeLibrary
relaxDatatypeLib' :: DatatypeLibrary
relaxDatatypeLib'       = ("",             DatatypeAllows
-> DatatypeEqual -> AllowedDatatypes -> DatatypeCheck
DTC DatatypeAllows
datatypeAllowsRelax DatatypeEqual
datatypeEqualRelax AllowedDatatypes
relaxDatatypes)

-- | The build in Relax NG datatype lib supportes only the token and string datatype,
-- without any params.

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

-- | If the token datatype is used, the values have to be normalized
-- (trailing and leading whitespaces are removed).
-- token does not perform any changes to the values.

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 )
      ]


-- --------------------------------------------------------------------------------------