content: -- ------------------------------------------------------------
  
  {- |
     Module     : Text.XML.HXT.XMLSchema.DataTypeLibW3C
     Copyright  : Copyright (C) 2005-2010 Uwe Schmidt
     License    : MIT
  
     Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
     Stability  : experimental
     Portability: portable
     Version    : $Id$
  
     Datatype library for the W3C XML schema datatypes
  
  -}
  
  -- ------------------------------------------------------------
  
  module Text.XML.HXT.RelaxNG.XMLSchema.DataTypeLibW3C
    ( module Text.XML.HXT.XMLSchema.DataTypeLibW3CNames
    , w3cDatatypeLib
    )
  where
  
  import           Data.Maybe
  import           Data.Ratio
  
  import           Network.URI                                (isURIReference)
  
  import           Text.Regex.XMLSchema.Generic               (Regex, isZero,
                                                               matchRE,
                                                               parseRegex)
  
  import           Text.XML.HXT.DOM.QualifiedName             (isNCName, isWellformedQualifiedName)
  import           Text.XML.HXT.XMLSchema.DataTypeLibW3CNames
  
  import           Text.XML.HXT.RelaxNG.DataTypeLibUtils
  
  -- ------------------------------------------------------------
  
  -- | The main entry point to the W3C XML schema datatype library.
  --
  -- The 'DTC' constructor exports the list of supported datatypes and params.
  -- It also exports the specialized functions to validate a XML instance value with
  -- respect to a datatype.
  w3cDatatypeLib :: DatatypeLibrary
  w3cDatatypeLib = (w3cNS, DTC datatypeAllowsW3C datatypeEqualW3C w3cDatatypes)
  
  
  -- | All supported datatypes of the library
  w3cDatatypes :: AllowedDatatypes
  w3cDatatypes = [ (xsd_string,                   stringParams)
                 , (xsd_normalizedString,         stringParams)
                 , (xsd_token,                    stringParams)
                 , (xsd_language,                 stringParams)
                 , (xsd_NMTOKEN,                  stringParams)
                 , (xsd_NMTOKENS,                 listParams  )
                 , (xsd_Name,                     stringParams)
                 , (xsd_NCName,                   stringParams)
                 , (xsd_ID,                       stringParams)
                 , (xsd_IDREF,                    stringParams)
                 , (xsd_IDREFS,                   listParams  )
                 , (xsd_ENTITY,                   stringParams)
                 , (xsd_ENTITIES,                 listParams  )
                 , (xsd_anyURI,                   stringParams)
                 , (xsd_QName,                    stringParams)
                 , (xsd_NOTATION,                 stringParams)
                 , (xsd_hexBinary,                stringParams)
                 , (xsd_base64Binary,             stringParams)
                 , (xsd_decimal,                  decimalParams)
                 , (xsd_integer,                  integerParams)
                 , (xsd_nonPositiveInteger,       integerParams)
                 , (xsd_negativeInteger,          integerParams)
                 , (xsd_nonNegativeInteger,       integerParams)
                 , (xsd_positiveInteger,          integerParams)
                 , (xsd_long,                     integerParams)
                 , (xsd_int,                      integerParams)
                 , (xsd_short,                    integerParams)
                 , (xsd_byte,                     integerParams)
                 , (xsd_unsignedLong,             integerParams)
                 , (xsd_unsignedInt,              integerParams)
                 , (xsd_unsignedShort,            integerParams)
                 , (xsd_unsignedByte,             integerParams)
                 ]
  
  -- ----------------------------------------
  
  -- | List of allowed params for the string datatypes
  stringParams    :: AllowedParams
  stringParams    = xsd_pattern : map fst fctTableString
  
  -- ----------------------------------------
  
  patternValid    :: ParamList -> CheckString
  patternValid params
      = foldr (>>>) ok . map paramPatternValid $ params
        where
        paramPatternValid (pn, pv)
            | pn == xsd_pattern   = assert (patParamValid pv) (errorMsgParam pn pv)
            | otherwise           = ok
  
  patParamValid :: String -> String -> Bool
  patParamValid regex a
      | isZero ex = False
      | otherwise = matchRE ex a
      where
      ex = parseRegex regex
  
  -- ----------------------------------------
  
  -- | List of allowed params for the decimal datatypes
  
  decimalParams   :: AllowedParams
  decimalParams   = xsd_pattern : map fst fctTableDecimal
  
  fctTableDecimal :: [(String, String -> Rational -> Bool)]
  fctTableDecimal
      = [ (xsd_maxExclusive,   cvd (>))
        , (xsd_minExclusive,   cvd (<))
        , (xsd_maxInclusive,   cvd (>=))
        , (xsd_minInclusive,   cvd (<=))
        , (xsd_totalDigits,    cvi (\ l v ->    totalDigits v == l))
        , (xsd_fractionDigits, cvi (\ l v -> fractionDigits v == l))
        ]
      where
      cvd         :: (Rational -> Rational -> Bool) -> (String -> Rational -> Bool)
      cvd op      = \ x y -> isDecimal x && readDecimal x `op` y
  
      cvi         :: (Int -> Rational -> Bool) -> (String -> Rational -> Bool)
      cvi op      = \ x y -> isNumber x && read x `op` y
  
  decimalValid    :: ParamList -> CheckA Rational Rational
  decimalValid params
      = foldr (>>>) ok . map paramDecimalValid $ params
      where
      paramDecimalValid (pn, pv)
          = assert
            ((fromMaybe (const . const $ True) . lookup pn $ fctTableDecimal) pv)
            (errorMsgParam pn pv . showDecimal)
  
  -- ----------------------------------------
  
  -- | List of allowed params for the decimal and integer datatypes
  
  integerParams   :: AllowedParams
  integerParams   = xsd_pattern : map fst fctTableInteger
  
  fctTableInteger :: [(String, String -> Integer -> Bool)]
  fctTableInteger
      = [ (xsd_maxExclusive,   cvi (>))
        , (xsd_minExclusive,   cvi (<))
        , (xsd_maxInclusive,   cvi (>=))
        , (xsd_minInclusive,   cvi (<=))
        , (xsd_totalDigits,    cvi (\ l v -> totalD v == toInteger l))
        ]
      where
      cvi         :: (Integer -> Integer -> Bool) -> (String -> Integer -> Bool)
      cvi op      = \ x y -> isNumber x && read x `op` y
  
      totalD i
          | i < 0     = totalD (0-i)
          | otherwise = toInteger . length . show $ i
  
  integerValid    :: DatatypeName -> ParamList -> CheckA Integer Integer
  integerValid datatype params
      = assertInRange
        >>>
        (foldr (>>>) ok . map paramIntegerValid $ params)
      where
      assertInRange       :: CheckA Integer Integer
      assertInRange
          = assert
            (fromMaybe (const True) . lookup datatype $ integerRangeTable)
            (\ v -> ( "Datatype " ++ show datatype ++
                      " with value = " ++ show v ++
                      " not in integer value range"
                    )
            )
      paramIntegerValid (pn, pv)
          = assert
            ((fromMaybe (const . const $ True) . lookup pn $ fctTableInteger) pv)
            (errorMsgParam pn pv . show)
  
  integerRangeTable       :: [(String, Integer -> Bool)]
  integerRangeTable       = [ (xsd_integer,               const True)
                            , (xsd_nonPositiveInteger,    (<=0)   )
                            , (xsd_negativeInteger,       ( <0)   )
                            , (xsd_nonNegativeInteger,    (>=0)   )
                            , (xsd_positiveInteger,       ( >0)   )
                            , (xsd_long,                  inR 9223372036854775808)
                            , (xsd_int,                   inR 2147483648)
                            , (xsd_short,                 inR 32768)
                            , (xsd_byte,                  inR 128)
                            , (xsd_unsignedLong,          inP 18446744073709551616)
                            , (xsd_unsignedInt,           inP 4294967296)
                            , (xsd_unsignedShort,         inP 65536)
                            , (xsd_unsignedByte,          inP 256)
                            ]
                            where
                            inR b i       = (0 - b) <= i && i < b
                            inP b i       = 0 <= i       && i < b
  
  -- ----------------------------------------
  
  -- | List of allowed params for the list datatypes
  
  listParams      :: AllowedParams
  listParams      = xsd_pattern : map fst fctTableList
  
  listValid       :: DatatypeName -> ParamList -> CheckString
  listValid d     = stringValidFT fctTableList d 0 (-1)
  
  -- ----------------------------------------
  
  isNameList      :: (String -> Bool) -> String -> Bool
  isNameList p w
      = not (null ts) && all p ts
        where
        ts = words w
  
  -- ----------------------------------------
  
  rex             :: String -> Regex
  rex regex
      | isZero ex = error $ "syntax error in regexp " ++ show regex
      | otherwise = ex
      where
      ex = parseRegex regex
  
  -- ----------------------------------------
  
  rexLanguage
    , rexHexBinary
    , rexBase64Binary
    , rexDecimal
    , rexInteger  :: Regex
  
  rexLanguage     = rex "[A-Za-z]{1,8}(-[A-Za-z]{1,8})*"
  rexHexBinary    = rex "([A-Fa-f0-9]{2})*"
  rexBase64Binary = rex $
                    "(" ++ b64 ++ "{4})*((" ++ b64 ++ "{2}==)|(" ++ b64 ++ "{3}=)|)"
                    where
                    b64     = "[A-Za-z0-9+/]"
  rexDecimal      = rex "(\\+|-)?(([0-9]+(\\.[0-9]*)?)|(\\.[0-9]+))"
  rexInteger      = rex "(\\+|-)?[0-9]+"
  
  isLanguage
    , isHexBinary
    , isBase64Binary
    , isDecimal
    , isInteger   :: String -> Bool
  
  isLanguage      = matchRE rexLanguage
  isHexBinary     = matchRE rexHexBinary
  isBase64Binary  = matchRE rexBase64Binary
  isDecimal       = matchRE rexDecimal
  isInteger       = matchRE rexInteger
  
  -- ----------------------------------------
  
  normBase64      :: String -> String
  normBase64      = filter isB64
                    where
                    isB64 c = ( 'A' <= c && c <= 'Z')
                              ||
                              ( 'a' <= c && c <= 'z')
                              ||
                              ( '0' <= c && c <= '9')
                              ||
                              c == '+'
                              ||
                              c == '/'
                              ||
                              c == '='
  
  -- ----------------------------------------
  
  readDecimal
    , readDecimal'        :: String -> Rational
  
  readDecimal ('+':s)     = readDecimal' s
  readDecimal ('-':s)     = negate (readDecimal' s)
  readDecimal      s      = readDecimal' s
  
  readDecimal' s
      | f == 0    = (n % 1)
      | otherwise = (n % 1) + (f % (10 ^ (toInteger (length fs))))
      where
      (ns, fs') = span (/= '.') s
      fs = drop 1 fs'
  
      f :: Integer
      f | null fs         = 0
        | otherwise       = read fs
      n :: Integer
      n | null ns         = 0
        | otherwise       = read ns
  
  totalDigits
    , totalDigits'
    , fractionDigits      :: Rational -> Int
  
  totalDigits r
      | r == 0                    = 0
      | r < 0                     = totalDigits' . negate  $ r
      | otherwise                 = totalDigits'           $ r
  
  totalDigits' r
      | denominator r == 1        = length . show . numerator  $ r
      | r < (1%1)                 = (\ x -> x-1) . totalDigits' . (+ (1%1))    $ r
      | otherwise                 = totalDigits' . (* (10 % 1)) $ r
  
  fractionDigits r
      | denominator r == 1        = 0
      | otherwise                 = (+1) . fractionDigits . (* (10 % 1)) $ r
  
  showDecimal
    , showDecimal'                :: Rational -> String
  
  showDecimal d
      | d < 0     = ('-':) . showDecimal' . negate    $ d
      | d < 1     = drop 1 . showDecimal' . (+ (1%1)) $ d
      | otherwise =          showDecimal'             $ d
  
  showDecimal' d
      | denominator d == 1        = show . numerator $ d
      | otherwise                 = times10 0        $ d
      where
      times10 i' d'
          | denominator d' == 1   = let
                                    (x, y) = splitAt i' . reverse . show . numerator $ d'
                                    in
                                    reverse y ++ "." ++ reverse x
          | otherwise             = times10 (i' + 1) (d' * (10 % 1))
  
  -- ----------------------------------------
  
  -- | Tests whether a XML instance value matches a data-pattern.
  -- (see also: 'stringValid')
  
  datatypeAllowsW3C :: DatatypeAllows
  datatypeAllowsW3C d params value _
      = performCheck check value
      where
      validString normFct
          = validPattern
            >>>
            arr normFct
            >>>
            validLength
  
      validNormString
          = validString normalizeWhitespace
  
      validPattern
          = patternValid params
  
      validLength
          = stringValid d 0 (-1) params
  
      validList
          = validPattern
            >>>
            arr normalizeWhitespace
            >>>
            validListLength
  
      validListLength
          = listValid d params
  
      validName isN
          = assertW3C isN
  
      validNCName
          = validNormString >>> validName isNCName
  
      validQName
          = validNormString >>> validName isWellformedQualifiedName
  
      validDecimal
          = arr normalizeWhitespace
            >>>
            assertW3C isDecimal
            >>>
            checkWith readDecimal (decimalValid params)
  
      validInteger inRange
          = validPattern
            >>>
            arr normalizeWhitespace
            >>>
            assertW3C isInteger
            >>>
            checkWith read (integerValid inRange params)
  
      check       :: CheckString
      check       = fromMaybe notFound . lookup d $ checks
  
      notFound    = failure $ errorMsgDataTypeNotAllowed w3cNS d params
  
      checks      :: [(String, CheckA String String)]
      checks      = [ (xsd_string,                validString id)
                    , (xsd_normalizedString,      validString normalizeBlanks)
                    , (xsd_token,                 validNormString)
                    , (xsd_language,              validNormString >>> assertW3C isLanguage)
                    , (xsd_NMTOKEN,               validNormString >>> validName isNmtoken)
                    , (xsd_NMTOKENS,              validList       >>> validName (isNameList isNmtoken))
                    , (xsd_Name,                  validNormString >>> validName isName)
                    , (xsd_NCName,                validNCName)
                    , (xsd_ID,                    validNCName)
                    , (xsd_IDREF,                 validNCName)
                    , (xsd_IDREFS,                validList       >>> validName (isNameList isNCName))
                    , (xsd_ENTITY,                validNCName)
                    , (xsd_ENTITIES,              validList       >>> validName (isNameList isNCName))
                    , (xsd_anyURI,                validName isURIReference >>> validString escapeURI)
                    , (xsd_QName,                 validQName)
                    , (xsd_NOTATION,              validQName)
                    , (xsd_hexBinary,             validString id         >>> assertW3C isHexBinary)
                    , (xsd_base64Binary,          validString normBase64 >>> assertW3C isBase64Binary)
                    , (xsd_decimal,               validPattern >>> validDecimal)
                    , (xsd_integer,               validInteger xsd_integer)
                    , (xsd_nonPositiveInteger,    validInteger xsd_nonPositiveInteger)
                    , (xsd_negativeInteger,       validInteger xsd_negativeInteger)
                    , (xsd_nonNegativeInteger,    validInteger xsd_nonNegativeInteger)
                    , (xsd_positiveInteger,       validInteger xsd_positiveInteger)
                    , (xsd_long,                  validInteger xsd_long)
                    , (xsd_int,                   validInteger xsd_int)
                    , (xsd_short,                 validInteger xsd_short)
                    , (xsd_byte,                  validInteger xsd_byte)
                    , (xsd_unsignedLong,          validInteger xsd_unsignedLong)
                    , (xsd_unsignedInt,           validInteger xsd_unsignedInt)
                    , (xsd_unsignedShort,         validInteger xsd_unsignedShort)
                    , (xsd_unsignedByte,          validInteger xsd_unsignedByte)
                    ]
      assertW3C p = assert p errW3C
      errW3C      = errorMsgDataLibQName w3cNS d
  
  -- ----------------------------------------
  
  -- | Tests whether a XML instance value matches a value-pattern.
  
  datatypeEqualW3C :: DatatypeEqual
  datatypeEqualW3C d s1 _ s2 _
      = performCheck check (s1, s2)
      where
      check       :: CheckA (String, String) (String, String)
      check       = maybe notFound found . lookup d $ norm
  
      notFound    = failure $ const (errorMsgDataTypeNotAllowed0 w3cNS d)
  
      found nf    = arr (\ (x1, x2) -> (nf x1, nf x2))                    -- normalize both values
                    >>>
                    assert (uncurry (==)) (uncurry $ errorMsgEqual d)     -- and check on (==)
  
      norm = [ (xsd_string,               id                      )
             , (xsd_normalizedString,     normalizeBlanks         )
             , (xsd_token,                normalizeWhitespace     )
             , (xsd_language,             normalizeWhitespace     )
             , (xsd_NMTOKEN,              normalizeWhitespace     )
             , (xsd_NMTOKENS,             normalizeWhitespace     )
             , (xsd_Name,                 normalizeWhitespace     )
             , (xsd_NCName,               normalizeWhitespace     )
             , (xsd_ID,                   normalizeWhitespace     )
             , (xsd_IDREF,                normalizeWhitespace     )
             , (xsd_IDREFS,               normalizeWhitespace     )
             , (xsd_ENTITY,               normalizeWhitespace     )
             , (xsd_ENTITIES,             normalizeWhitespace     )
             , (xsd_anyURI,               escapeURI . normalizeWhitespace )
             , (xsd_QName,                normalizeWhitespace     )
             , (xsd_NOTATION,             normalizeWhitespace     )
             , (xsd_hexBinary,            id                      )
             , (xsd_base64Binary,         normBase64              )
             , (xsd_decimal,              show . readDecimal . normalizeWhitespace        )
             ]
  
  -- ----------------------------------------
  