-- | 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 :: String -> DatatypeEqual
datatypeEqual String
uri String
d String
s1 Context
c1 String
s2 Context
c2
    = if String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem String
uri ((DatatypeLibrary -> String) -> DatatypeLibraries -> [String]
forall a b. (a -> b) -> [a] -> [b]
map DatatypeLibrary -> String
forall a b. (a, b) -> a
fst DatatypeLibraries
datatypeLibraries)
      then DatatypeEqual
dtEqFct String
d String
s1 Context
c1 String
s2 Context
c2
      else String -> Maybe String
forall a. a -> Maybe a
Just ( String
"Unknown DatatypeLibrary " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
uri )
    where
    DTC DatatypeAllows
_ DatatypeEqual
dtEqFct AllowedDatatypes
_ = Maybe DatatypeCheck -> DatatypeCheck
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe DatatypeCheck -> DatatypeCheck)
-> Maybe DatatypeCheck -> DatatypeCheck
forall a b. (a -> b) -> a -> b
$ String -> DatatypeLibraries -> Maybe DatatypeCheck
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
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 :: String -> DatatypeAllows
datatypeAllows String
uri String
d ParamList
params String
s1 Context
c1
    = if String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem String
uri ((DatatypeLibrary -> String) -> DatatypeLibraries -> [String]
forall a b. (a -> b) -> [a] -> [b]
map DatatypeLibrary -> String
forall a b. (a, b) -> a
fst DatatypeLibraries
datatypeLibraries)
      then DatatypeAllows
dtAllowFct String
d ParamList
params String
s1 Context
c1
      else String -> Maybe String
forall a. a -> Maybe a
Just ( String
"Unknown DatatypeLibrary " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
uri )
    where
    DTC DatatypeAllows
dtAllowFct DatatypeEqual
_ AllowedDatatypes
_ = Maybe DatatypeCheck -> DatatypeCheck
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe DatatypeCheck -> DatatypeCheck)
-> Maybe DatatypeCheck -> DatatypeCheck
forall a b. (a -> b) -> a -> b
$ String -> DatatypeLibraries -> Maybe DatatypeCheck
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
uri DatatypeLibraries
datatypeLibraries


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

relaxDatatypeLib        :: DatatypeLibrary
relaxDatatypeLib :: DatatypeLibrary
relaxDatatypeLib        = (String
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'       = (String
"",             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
    = ((String, String -> String -> Bool) -> (String, [String]))
-> [(String, String -> String -> Bool)] -> AllowedDatatypes
forall a b. (a -> b) -> [a] -> [b]
map ( (\ String
x -> (String
x, [])) (String -> (String, [String]))
-> ((String, String -> String -> Bool) -> String)
-> (String, String -> String -> Bool)
-> (String, [String])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, String -> String -> Bool) -> String
forall a b. (a, b) -> a
fst ) [(String, String -> String -> Bool)]
relaxDatatypeTable

datatypeAllowsRelax :: DatatypeAllows
datatypeAllowsRelax :: DatatypeAllows
datatypeAllowsRelax String
d ParamList
p String
v Context
_
    = Maybe String
-> ((String -> String -> Bool) -> Maybe String)
-> Maybe (String -> String -> Bool)
-> Maybe String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Maybe String
notAllowed' (String -> String -> Bool) -> Maybe String
forall {p} {a}. p -> Maybe a
allowed (Maybe (String -> String -> Bool) -> Maybe String)
-> ([(String, String -> String -> Bool)]
    -> Maybe (String -> String -> Bool))
-> [(String, String -> String -> Bool)]
-> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String
-> [(String, String -> String -> Bool)]
-> Maybe (String -> String -> Bool)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
d ([(String, String -> String -> Bool)] -> Maybe String)
-> [(String, String -> String -> Bool)] -> Maybe String
forall a b. (a -> b) -> a -> b
$ [(String, String -> String -> Bool)]
relaxDatatypeTable
    where
    notAllowed' :: Maybe String
notAllowed'
        = String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String -> String -> ParamList -> String -> String
errorMsgDataTypeNotAllowed String
relaxNamespace String
d ParamList
p String
v
    allowed :: p -> Maybe a
allowed p
_
        = 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 String
d String
s1 Context
_ String
s2 Context
_
    = Maybe String
-> ((String -> String -> Bool) -> Maybe String)
-> Maybe (String -> String -> Bool)
-> Maybe String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Maybe String
notAllowed' (String -> String -> Bool) -> Maybe String
checkValues (Maybe (String -> String -> Bool) -> Maybe String)
-> ([(String, String -> String -> Bool)]
    -> Maybe (String -> String -> Bool))
-> [(String, String -> String -> Bool)]
-> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String
-> [(String, String -> String -> Bool)]
-> Maybe (String -> String -> Bool)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
d ([(String, String -> String -> Bool)] -> Maybe String)
-> [(String, String -> String -> Bool)] -> Maybe String
forall a b. (a -> b) -> a -> b
$ [(String, String -> String -> Bool)]
relaxDatatypeTable
      where
      notAllowed' :: Maybe String
notAllowed'
          = String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String -> String -> String -> String -> String
errorMsgDataTypeNotAllowed2 String
relaxNamespace String
d String
s1 String
s2
      checkValues :: (String -> String -> Bool) -> Maybe String
checkValues String -> String -> Bool
predicate
          = if String -> String -> Bool
predicate String
s1 String
s2
            then Maybe String
forall a. Maybe a
Nothing
            else String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String -> String -> String -> String
errorMsgEqual String
d String
s1 String
s2

relaxDatatypeTable :: [(String, String -> String -> Bool)]
relaxDatatypeTable :: [(String, String -> String -> Bool)]
relaxDatatypeTable
    = [ (String
"string", String -> String -> Bool
forall a. Eq a => a -> a -> Bool
(==))
      , (String
"token",  \ String
s1 String
s2 -> String -> String
normalizeWhitespace String
s1 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String -> String
normalizeWhitespace String
s2 )
      ]


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