-- | 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
    = [ relaxDatatypeLib
      , relaxDatatypeLib'
      , mysqlDatatypeLib
      , 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 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

{- |
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 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


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

relaxDatatypeLib        :: DatatypeLibrary
relaxDatatypeLib        = (relaxNamespace, DTC datatypeAllowsRelax datatypeEqualRelax relaxDatatypes)

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

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

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

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


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