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

{- |
   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 :: DatatypeLibrary
w3cDatatypeLib = (DatatypeName
w3cNS, DatatypeAllows
-> DatatypeEqual -> AllowedDatatypes -> DatatypeCheck
DTC DatatypeAllows
datatypeAllowsW3C DatatypeEqual
datatypeEqualW3C AllowedDatatypes
w3cDatatypes)


-- | All supported datatypes of the library
w3cDatatypes :: AllowedDatatypes
w3cDatatypes :: AllowedDatatypes
w3cDatatypes = [ (DatatypeName
xsd_string,                   AllowedParams
stringParams)
               , (DatatypeName
xsd_normalizedString,         AllowedParams
stringParams)
               , (DatatypeName
xsd_token,                    AllowedParams
stringParams)
               , (DatatypeName
xsd_language,                 AllowedParams
stringParams)
               , (DatatypeName
xsd_NMTOKEN,                  AllowedParams
stringParams)
               , (DatatypeName
xsd_NMTOKENS,                 AllowedParams
listParams  )
               , (DatatypeName
xsd_Name,                     AllowedParams
stringParams)
               , (DatatypeName
xsd_NCName,                   AllowedParams
stringParams)
               , (DatatypeName
xsd_ID,                       AllowedParams
stringParams)
               , (DatatypeName
xsd_IDREF,                    AllowedParams
stringParams)
               , (DatatypeName
xsd_IDREFS,                   AllowedParams
listParams  )
               , (DatatypeName
xsd_ENTITY,                   AllowedParams
stringParams)
               , (DatatypeName
xsd_ENTITIES,                 AllowedParams
listParams  )
               , (DatatypeName
xsd_anyURI,                   AllowedParams
stringParams)
               , (DatatypeName
xsd_QName,                    AllowedParams
stringParams)
               , (DatatypeName
xsd_NOTATION,                 AllowedParams
stringParams)
               , (DatatypeName
xsd_hexBinary,                AllowedParams
stringParams)
               , (DatatypeName
xsd_base64Binary,             AllowedParams
stringParams)
               , (DatatypeName
xsd_decimal,                  AllowedParams
decimalParams)
               , (DatatypeName
xsd_integer,                  AllowedParams
integerParams)
               , (DatatypeName
xsd_nonPositiveInteger,       AllowedParams
integerParams)
               , (DatatypeName
xsd_negativeInteger,          AllowedParams
integerParams)
               , (DatatypeName
xsd_nonNegativeInteger,       AllowedParams
integerParams)
               , (DatatypeName
xsd_positiveInteger,          AllowedParams
integerParams)
               , (DatatypeName
xsd_long,                     AllowedParams
integerParams)
               , (DatatypeName
xsd_int,                      AllowedParams
integerParams)
               , (DatatypeName
xsd_short,                    AllowedParams
integerParams)
               , (DatatypeName
xsd_byte,                     AllowedParams
integerParams)
               , (DatatypeName
xsd_unsignedLong,             AllowedParams
integerParams)
               , (DatatypeName
xsd_unsignedInt,              AllowedParams
integerParams)
               , (DatatypeName
xsd_unsignedShort,            AllowedParams
integerParams)
               , (DatatypeName
xsd_unsignedByte,             AllowedParams
integerParams)
               ]

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

-- | List of allowed params for the string datatypes
stringParams    :: AllowedParams
stringParams :: AllowedParams
stringParams    = DatatypeName
xsd_pattern DatatypeName -> AllowedParams -> AllowedParams
forall a. a -> [a] -> [a]
: ((DatatypeName, DatatypeName -> DatatypeName -> Bool)
 -> DatatypeName)
-> [(DatatypeName, DatatypeName -> DatatypeName -> Bool)]
-> AllowedParams
forall a b. (a -> b) -> [a] -> [b]
map (DatatypeName, DatatypeName -> DatatypeName -> Bool)
-> DatatypeName
forall a b. (a, b) -> a
fst [(DatatypeName, DatatypeName -> DatatypeName -> Bool)]
fctTableString

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

patternValid    :: ParamList -> CheckString
patternValid :: ParamList -> CheckString
patternValid ParamList
params
    = (CheckString -> CheckString -> CheckString)
-> CheckString -> [CheckString] -> CheckString
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr CheckString -> CheckString -> CheckString
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
(>>>) CheckString
forall a. CheckA a a
ok ([CheckString] -> CheckString)
-> (ParamList -> [CheckString]) -> ParamList -> CheckString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((DatatypeName, DatatypeName) -> CheckString)
-> ParamList -> [CheckString]
forall a b. (a -> b) -> [a] -> [b]
map (DatatypeName, DatatypeName) -> CheckString
paramPatternValid (ParamList -> CheckString) -> ParamList -> CheckString
forall a b. (a -> b) -> a -> b
$ ParamList
params
      where
      paramPatternValid :: (DatatypeName, DatatypeName) -> CheckString
paramPatternValid (DatatypeName
pn, DatatypeName
pv)
          | DatatypeName
pn DatatypeName -> DatatypeName -> Bool
forall a. Eq a => a -> a -> Bool
== DatatypeName
xsd_pattern   = (DatatypeName -> Bool)
-> (DatatypeName -> DatatypeName) -> CheckString
forall a. (a -> Bool) -> (a -> DatatypeName) -> CheckA a a
assert (DatatypeName -> DatatypeName -> Bool
patParamValid DatatypeName
pv) (DatatypeName -> DatatypeName -> DatatypeName -> DatatypeName
errorMsgParam DatatypeName
pn DatatypeName
pv)
          | Bool
otherwise           = CheckString
forall a. CheckA a a
ok

patParamValid :: String -> String -> Bool
patParamValid :: DatatypeName -> DatatypeName -> Bool
patParamValid DatatypeName
regex DatatypeName
a
    | GenRegex DatatypeName -> Bool
forall s. GenRegex s -> Bool
isZero GenRegex DatatypeName
ex = Bool
False
    | Bool
otherwise = GenRegex DatatypeName -> DatatypeName -> Bool
forall s. StringLike s => GenRegex s -> s -> Bool
matchRE GenRegex DatatypeName
ex DatatypeName
a
    where
    ex :: GenRegex DatatypeName
ex = DatatypeName -> GenRegex DatatypeName
forall s. StringLike s => s -> GenRegex s
parseRegex DatatypeName
regex

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

-- | List of allowed params for the decimal datatypes

decimalParams   :: AllowedParams
decimalParams :: AllowedParams
decimalParams   = DatatypeName
xsd_pattern DatatypeName -> AllowedParams -> AllowedParams
forall a. a -> [a] -> [a]
: ((DatatypeName, DatatypeName -> Rational -> Bool) -> DatatypeName)
-> [(DatatypeName, DatatypeName -> Rational -> Bool)]
-> AllowedParams
forall a b. (a -> b) -> [a] -> [b]
map (DatatypeName, DatatypeName -> Rational -> Bool) -> DatatypeName
forall a b. (a, b) -> a
fst [(DatatypeName, DatatypeName -> Rational -> Bool)]
fctTableDecimal

fctTableDecimal :: [(String, String -> Rational -> Bool)]
fctTableDecimal :: [(DatatypeName, DatatypeName -> Rational -> Bool)]
fctTableDecimal
    = [ (DatatypeName
xsd_maxExclusive,   (Rational -> Rational -> Bool) -> DatatypeName -> Rational -> Bool
cvd Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
(>))
      , (DatatypeName
xsd_minExclusive,   (Rational -> Rational -> Bool) -> DatatypeName -> Rational -> Bool
cvd Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
(<))
      , (DatatypeName
xsd_maxInclusive,   (Rational -> Rational -> Bool) -> DatatypeName -> Rational -> Bool
cvd Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
(>=))
      , (DatatypeName
xsd_minInclusive,   (Rational -> Rational -> Bool) -> DatatypeName -> Rational -> Bool
cvd Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
(<=))
      , (DatatypeName
xsd_totalDigits,    (Int -> Rational -> Bool) -> DatatypeName -> Rational -> Bool
cvi (\ Int
l Rational
v ->    Rational -> Int
totalDigits Rational
v Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
l))
      , (DatatypeName
xsd_fractionDigits, (Int -> Rational -> Bool) -> DatatypeName -> Rational -> Bool
cvi (\ Int
l Rational
v -> Rational -> Int
fractionDigits Rational
v Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
l))
      ]
    where
    cvd         :: (Rational -> Rational -> Bool) -> (String -> Rational -> Bool)
    cvd :: (Rational -> Rational -> Bool) -> DatatypeName -> Rational -> Bool
cvd Rational -> Rational -> Bool
op      = \ DatatypeName
x Rational
y -> DatatypeName -> Bool
isDecimal DatatypeName
x Bool -> Bool -> Bool
&& DatatypeName -> Rational
readDecimal DatatypeName
x Rational -> Rational -> Bool
`op` Rational
y

    cvi         :: (Int -> Rational -> Bool) -> (String -> Rational -> Bool)
    cvi :: (Int -> Rational -> Bool) -> DatatypeName -> Rational -> Bool
cvi Int -> Rational -> Bool
op      = \ DatatypeName
x Rational
y -> DatatypeName -> Bool
isNumber DatatypeName
x Bool -> Bool -> Bool
&& DatatypeName -> Int
forall a. Read a => DatatypeName -> a
read DatatypeName
x Int -> Rational -> Bool
`op` Rational
y

decimalValid    :: ParamList -> CheckA Rational Rational
decimalValid :: ParamList -> CheckA Rational Rational
decimalValid ParamList
params
    = (CheckA Rational Rational
 -> CheckA Rational Rational -> CheckA Rational Rational)
-> CheckA Rational Rational
-> [CheckA Rational Rational]
-> CheckA Rational Rational
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr CheckA Rational Rational
-> CheckA Rational Rational -> CheckA Rational Rational
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
(>>>) CheckA Rational Rational
forall a. CheckA a a
ok ([CheckA Rational Rational] -> CheckA Rational Rational)
-> (ParamList -> [CheckA Rational Rational])
-> ParamList
-> CheckA Rational Rational
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((DatatypeName, DatatypeName) -> CheckA Rational Rational)
-> ParamList -> [CheckA Rational Rational]
forall a b. (a -> b) -> [a] -> [b]
map (DatatypeName, DatatypeName) -> CheckA Rational Rational
paramDecimalValid (ParamList -> CheckA Rational Rational)
-> ParamList -> CheckA Rational Rational
forall a b. (a -> b) -> a -> b
$ ParamList
params
    where
    paramDecimalValid :: (DatatypeName, DatatypeName) -> CheckA Rational Rational
paramDecimalValid (DatatypeName
pn, DatatypeName
pv)
        = (Rational -> Bool)
-> (Rational -> DatatypeName) -> CheckA Rational Rational
forall a. (a -> Bool) -> (a -> DatatypeName) -> CheckA a a
assert
          (((DatatypeName -> Rational -> Bool)
-> Maybe (DatatypeName -> Rational -> Bool)
-> DatatypeName
-> Rational
-> Bool
forall a. a -> Maybe a -> a
fromMaybe ((Rational -> Bool) -> DatatypeName -> Rational -> Bool
forall a b. a -> b -> a
const ((Rational -> Bool) -> DatatypeName -> Rational -> Bool)
-> (Bool -> Rational -> Bool)
-> Bool
-> DatatypeName
-> Rational
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Rational -> Bool
forall a b. a -> b -> a
const (Bool -> DatatypeName -> Rational -> Bool)
-> Bool -> DatatypeName -> Rational -> Bool
forall a b. (a -> b) -> a -> b
$ Bool
True) (Maybe (DatatypeName -> Rational -> Bool)
 -> DatatypeName -> Rational -> Bool)
-> ([(DatatypeName, DatatypeName -> Rational -> Bool)]
    -> Maybe (DatatypeName -> Rational -> Bool))
-> [(DatatypeName, DatatypeName -> Rational -> Bool)]
-> DatatypeName
-> Rational
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DatatypeName
-> [(DatatypeName, DatatypeName -> Rational -> Bool)]
-> Maybe (DatatypeName -> Rational -> Bool)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup DatatypeName
pn ([(DatatypeName, DatatypeName -> Rational -> Bool)]
 -> DatatypeName -> Rational -> Bool)
-> [(DatatypeName, DatatypeName -> Rational -> Bool)]
-> DatatypeName
-> Rational
-> Bool
forall a b. (a -> b) -> a -> b
$ [(DatatypeName, DatatypeName -> Rational -> Bool)]
fctTableDecimal) DatatypeName
pv)
          (DatatypeName -> DatatypeName -> DatatypeName -> DatatypeName
errorMsgParam DatatypeName
pn DatatypeName
pv (DatatypeName -> DatatypeName)
-> (Rational -> DatatypeName) -> Rational -> DatatypeName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rational -> DatatypeName
showDecimal)

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

-- | List of allowed params for the decimal and integer datatypes

integerParams   :: AllowedParams
integerParams :: AllowedParams
integerParams   = DatatypeName
xsd_pattern DatatypeName -> AllowedParams -> AllowedParams
forall a. a -> [a] -> [a]
: ((DatatypeName, DatatypeName -> Integer -> Bool) -> DatatypeName)
-> [(DatatypeName, DatatypeName -> Integer -> Bool)]
-> AllowedParams
forall a b. (a -> b) -> [a] -> [b]
map (DatatypeName, DatatypeName -> Integer -> Bool) -> DatatypeName
forall a b. (a, b) -> a
fst [(DatatypeName, DatatypeName -> Integer -> Bool)]
fctTableInteger

fctTableInteger :: [(String, String -> Integer -> Bool)]
fctTableInteger :: [(DatatypeName, DatatypeName -> Integer -> Bool)]
fctTableInteger
    = [ (DatatypeName
xsd_maxExclusive,   (Integer -> Integer -> Bool) -> DatatypeName -> Integer -> Bool
cvi Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
(>))
      , (DatatypeName
xsd_minExclusive,   (Integer -> Integer -> Bool) -> DatatypeName -> Integer -> Bool
cvi Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
(<))
      , (DatatypeName
xsd_maxInclusive,   (Integer -> Integer -> Bool) -> DatatypeName -> Integer -> Bool
cvi Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
(>=))
      , (DatatypeName
xsd_minInclusive,   (Integer -> Integer -> Bool) -> DatatypeName -> Integer -> Bool
cvi Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
(<=))
      , (DatatypeName
xsd_totalDigits,    (Integer -> Integer -> Bool) -> DatatypeName -> Integer -> Bool
cvi (\ Integer
l Integer
v -> Integer -> Integer
forall {a}. (Ord a, Num a, Show a) => a -> Integer
totalD Integer
v Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer -> Integer
forall a. Integral a => a -> Integer
toInteger Integer
l))
      ]
    where
    cvi         :: (Integer -> Integer -> Bool) -> (String -> Integer -> Bool)
    cvi :: (Integer -> Integer -> Bool) -> DatatypeName -> Integer -> Bool
cvi Integer -> Integer -> Bool
op      = \ DatatypeName
x Integer
y -> DatatypeName -> Bool
isNumber DatatypeName
x Bool -> Bool -> Bool
&& DatatypeName -> Integer
forall a. Read a => DatatypeName -> a
read DatatypeName
x Integer -> Integer -> Bool
`op` Integer
y

    totalD :: a -> Integer
totalD a
i
        | a
i a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0     = a -> Integer
totalD (a
0a -> a -> a
forall a. Num a => a -> a -> a
-a
i)
        | Bool
otherwise = Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer) -> (a -> Int) -> a -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DatatypeName -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (DatatypeName -> Int) -> (a -> DatatypeName) -> a -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> DatatypeName
forall a. Show a => a -> DatatypeName
show (a -> Integer) -> a -> Integer
forall a b. (a -> b) -> a -> b
$ a
i

integerValid    :: DatatypeName -> ParamList -> CheckA Integer Integer
integerValid :: DatatypeName -> ParamList -> CheckA Integer Integer
integerValid DatatypeName
datatype ParamList
params
    = CheckA Integer Integer
assertInRange
      CheckA Integer Integer
-> CheckA Integer Integer -> CheckA Integer Integer
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
      ((CheckA Integer Integer
 -> CheckA Integer Integer -> CheckA Integer Integer)
-> CheckA Integer Integer
-> [CheckA Integer Integer]
-> CheckA Integer Integer
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr CheckA Integer Integer
-> CheckA Integer Integer -> CheckA Integer Integer
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
(>>>) CheckA Integer Integer
forall a. CheckA a a
ok ([CheckA Integer Integer] -> CheckA Integer Integer)
-> (ParamList -> [CheckA Integer Integer])
-> ParamList
-> CheckA Integer Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((DatatypeName, DatatypeName) -> CheckA Integer Integer)
-> ParamList -> [CheckA Integer Integer]
forall a b. (a -> b) -> [a] -> [b]
map (DatatypeName, DatatypeName) -> CheckA Integer Integer
paramIntegerValid (ParamList -> CheckA Integer Integer)
-> ParamList -> CheckA Integer Integer
forall a b. (a -> b) -> a -> b
$ ParamList
params)
    where
    assertInRange       :: CheckA Integer Integer
    assertInRange :: CheckA Integer Integer
assertInRange
        = (Integer -> Bool)
-> (Integer -> DatatypeName) -> CheckA Integer Integer
forall a. (a -> Bool) -> (a -> DatatypeName) -> CheckA a a
assert
          ((Integer -> Bool) -> Maybe (Integer -> Bool) -> Integer -> Bool
forall a. a -> Maybe a -> a
fromMaybe (Bool -> Integer -> Bool
forall a b. a -> b -> a
const Bool
True) (Maybe (Integer -> Bool) -> Integer -> Bool)
-> ([(DatatypeName, Integer -> Bool)] -> Maybe (Integer -> Bool))
-> [(DatatypeName, Integer -> Bool)]
-> Integer
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DatatypeName
-> [(DatatypeName, Integer -> Bool)] -> Maybe (Integer -> Bool)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup DatatypeName
datatype ([(DatatypeName, Integer -> Bool)] -> Integer -> Bool)
-> [(DatatypeName, Integer -> Bool)] -> Integer -> Bool
forall a b. (a -> b) -> a -> b
$ [(DatatypeName, Integer -> Bool)]
integerRangeTable)
          (\ Integer
v -> ( DatatypeName
"Datatype " DatatypeName -> DatatypeName -> DatatypeName
forall a. [a] -> [a] -> [a]
++ DatatypeName -> DatatypeName
forall a. Show a => a -> DatatypeName
show DatatypeName
datatype DatatypeName -> DatatypeName -> DatatypeName
forall a. [a] -> [a] -> [a]
++
                    DatatypeName
" with value = " DatatypeName -> DatatypeName -> DatatypeName
forall a. [a] -> [a] -> [a]
++ Integer -> DatatypeName
forall a. Show a => a -> DatatypeName
show Integer
v DatatypeName -> DatatypeName -> DatatypeName
forall a. [a] -> [a] -> [a]
++
                    DatatypeName
" not in integer value range"
                  )
          )
    paramIntegerValid :: (DatatypeName, DatatypeName) -> CheckA Integer Integer
paramIntegerValid (DatatypeName
pn, DatatypeName
pv)
        = (Integer -> Bool)
-> (Integer -> DatatypeName) -> CheckA Integer Integer
forall a. (a -> Bool) -> (a -> DatatypeName) -> CheckA a a
assert
          (((DatatypeName -> Integer -> Bool)
-> Maybe (DatatypeName -> Integer -> Bool)
-> DatatypeName
-> Integer
-> Bool
forall a. a -> Maybe a -> a
fromMaybe ((Integer -> Bool) -> DatatypeName -> Integer -> Bool
forall a b. a -> b -> a
const ((Integer -> Bool) -> DatatypeName -> Integer -> Bool)
-> (Bool -> Integer -> Bool)
-> Bool
-> DatatypeName
-> Integer
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Integer -> Bool
forall a b. a -> b -> a
const (Bool -> DatatypeName -> Integer -> Bool)
-> Bool -> DatatypeName -> Integer -> Bool
forall a b. (a -> b) -> a -> b
$ Bool
True) (Maybe (DatatypeName -> Integer -> Bool)
 -> DatatypeName -> Integer -> Bool)
-> ([(DatatypeName, DatatypeName -> Integer -> Bool)]
    -> Maybe (DatatypeName -> Integer -> Bool))
-> [(DatatypeName, DatatypeName -> Integer -> Bool)]
-> DatatypeName
-> Integer
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DatatypeName
-> [(DatatypeName, DatatypeName -> Integer -> Bool)]
-> Maybe (DatatypeName -> Integer -> Bool)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup DatatypeName
pn ([(DatatypeName, DatatypeName -> Integer -> Bool)]
 -> DatatypeName -> Integer -> Bool)
-> [(DatatypeName, DatatypeName -> Integer -> Bool)]
-> DatatypeName
-> Integer
-> Bool
forall a b. (a -> b) -> a -> b
$ [(DatatypeName, DatatypeName -> Integer -> Bool)]
fctTableInteger) DatatypeName
pv)
          (DatatypeName -> DatatypeName -> DatatypeName -> DatatypeName
errorMsgParam DatatypeName
pn DatatypeName
pv (DatatypeName -> DatatypeName)
-> (Integer -> DatatypeName) -> Integer -> DatatypeName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> DatatypeName
forall a. Show a => a -> DatatypeName
show)

integerRangeTable       :: [(String, Integer -> Bool)]
integerRangeTable :: [(DatatypeName, Integer -> Bool)]
integerRangeTable       = [ (DatatypeName
xsd_integer,               Bool -> Integer -> Bool
forall a b. a -> b -> a
const Bool
True)
                          , (DatatypeName
xsd_nonPositiveInteger,    (Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<=Integer
0)   )
                          , (DatatypeName
xsd_negativeInteger,       ( Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<Integer
0)   )
                          , (DatatypeName
xsd_nonNegativeInteger,    (Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>=Integer
0)   )
                          , (DatatypeName
xsd_positiveInteger,       ( Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>Integer
0)   )
                          , (DatatypeName
xsd_long,                  Integer -> Integer -> Bool
forall {a}. (Ord a, Num a) => a -> a -> Bool
inR Integer
9223372036854775808)
                          , (DatatypeName
xsd_int,                   Integer -> Integer -> Bool
forall {a}. (Ord a, Num a) => a -> a -> Bool
inR Integer
2147483648)
                          , (DatatypeName
xsd_short,                 Integer -> Integer -> Bool
forall {a}. (Ord a, Num a) => a -> a -> Bool
inR Integer
32768)
                          , (DatatypeName
xsd_byte,                  Integer -> Integer -> Bool
forall {a}. (Ord a, Num a) => a -> a -> Bool
inR Integer
128)
                          , (DatatypeName
xsd_unsignedLong,          Integer -> Integer -> Bool
forall {a}. (Ord a, Num a) => a -> a -> Bool
inP Integer
18446744073709551616)
                          , (DatatypeName
xsd_unsignedInt,           Integer -> Integer -> Bool
forall {a}. (Ord a, Num a) => a -> a -> Bool
inP Integer
4294967296)
                          , (DatatypeName
xsd_unsignedShort,         Integer -> Integer -> Bool
forall {a}. (Ord a, Num a) => a -> a -> Bool
inP Integer
65536)
                          , (DatatypeName
xsd_unsignedByte,          Integer -> Integer -> Bool
forall {a}. (Ord a, Num a) => a -> a -> Bool
inP Integer
256)
                          ]
                          where
                          inR :: a -> a -> Bool
inR a
b a
i       = (a
0 a -> a -> a
forall a. Num a => a -> a -> a
- a
b) a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
i Bool -> Bool -> Bool
&& a
i a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
b
                          inP :: a -> a -> Bool
inP a
b a
i       = a
0 a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
i       Bool -> Bool -> Bool
&& a
i a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
b

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

-- | List of allowed params for the list datatypes

listParams      :: AllowedParams
listParams :: AllowedParams
listParams      = DatatypeName
xsd_pattern DatatypeName -> AllowedParams -> AllowedParams
forall a. a -> [a] -> [a]
: ((DatatypeName, DatatypeName -> DatatypeName -> Bool)
 -> DatatypeName)
-> [(DatatypeName, DatatypeName -> DatatypeName -> Bool)]
-> AllowedParams
forall a b. (a -> b) -> [a] -> [b]
map (DatatypeName, DatatypeName -> DatatypeName -> Bool)
-> DatatypeName
forall a b. (a, b) -> a
fst [(DatatypeName, DatatypeName -> DatatypeName -> Bool)]
fctTableList

listValid       :: DatatypeName -> ParamList -> CheckString
listValid :: DatatypeName -> ParamList -> CheckString
listValid DatatypeName
d     = [(DatatypeName, DatatypeName -> DatatypeName -> Bool)]
-> DatatypeName -> Integer -> Integer -> ParamList -> CheckString
stringValidFT [(DatatypeName, DatatypeName -> DatatypeName -> Bool)]
fctTableList DatatypeName
d Integer
0 (-Integer
1)

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

isNameList      :: (String -> Bool) -> String -> Bool
isNameList :: (DatatypeName -> Bool) -> DatatypeName -> Bool
isNameList DatatypeName -> Bool
p DatatypeName
w
    = Bool -> Bool
not (AllowedParams -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null AllowedParams
ts) Bool -> Bool -> Bool
&& (DatatypeName -> Bool) -> AllowedParams -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all DatatypeName -> Bool
p AllowedParams
ts
      where
      ts :: AllowedParams
ts = DatatypeName -> AllowedParams
words DatatypeName
w

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

rex             :: String -> Regex
rex :: DatatypeName -> GenRegex DatatypeName
rex DatatypeName
regex
    | GenRegex DatatypeName -> Bool
forall s. GenRegex s -> Bool
isZero GenRegex DatatypeName
ex = DatatypeName -> GenRegex DatatypeName
forall a. HasCallStack => DatatypeName -> a
error (DatatypeName -> GenRegex DatatypeName)
-> DatatypeName -> GenRegex DatatypeName
forall a b. (a -> b) -> a -> b
$ DatatypeName
"syntax error in regexp " DatatypeName -> DatatypeName -> DatatypeName
forall a. [a] -> [a] -> [a]
++ DatatypeName -> DatatypeName
forall a. Show a => a -> DatatypeName
show DatatypeName
regex
    | Bool
otherwise = GenRegex DatatypeName
ex
    where
    ex :: GenRegex DatatypeName
ex = DatatypeName -> GenRegex DatatypeName
forall s. StringLike s => s -> GenRegex s
parseRegex DatatypeName
regex

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

rexLanguage
  , rexHexBinary
  , rexBase64Binary
  , rexDecimal
  , rexInteger  :: Regex

rexLanguage :: GenRegex DatatypeName
rexLanguage     = DatatypeName -> GenRegex DatatypeName
rex DatatypeName
"[A-Za-z]{1,8}(-[A-Za-z]{1,8})*"
rexHexBinary :: GenRegex DatatypeName
rexHexBinary    = DatatypeName -> GenRegex DatatypeName
rex DatatypeName
"([A-Fa-f0-9]{2})*"
rexBase64Binary :: GenRegex DatatypeName
rexBase64Binary = DatatypeName -> GenRegex DatatypeName
rex (DatatypeName -> GenRegex DatatypeName)
-> DatatypeName -> GenRegex DatatypeName
forall a b. (a -> b) -> a -> b
$
                  DatatypeName
"(" DatatypeName -> DatatypeName -> DatatypeName
forall a. [a] -> [a] -> [a]
++ DatatypeName
b64 DatatypeName -> DatatypeName -> DatatypeName
forall a. [a] -> [a] -> [a]
++ DatatypeName
"{4})*((" DatatypeName -> DatatypeName -> DatatypeName
forall a. [a] -> [a] -> [a]
++ DatatypeName
b64 DatatypeName -> DatatypeName -> DatatypeName
forall a. [a] -> [a] -> [a]
++ DatatypeName
"{2}==)|(" DatatypeName -> DatatypeName -> DatatypeName
forall a. [a] -> [a] -> [a]
++ DatatypeName
b64 DatatypeName -> DatatypeName -> DatatypeName
forall a. [a] -> [a] -> [a]
++ DatatypeName
"{3}=)|)"
                  where
                  b64 :: DatatypeName
b64     = DatatypeName
"[A-Za-z0-9+/]"
rexDecimal :: GenRegex DatatypeName
rexDecimal      = DatatypeName -> GenRegex DatatypeName
rex DatatypeName
"(\\+|-)?(([0-9]+(\\.[0-9]*)?)|(\\.[0-9]+))"
rexInteger :: GenRegex DatatypeName
rexInteger      = DatatypeName -> GenRegex DatatypeName
rex DatatypeName
"(\\+|-)?[0-9]+"

isLanguage
  , isHexBinary
  , isBase64Binary
  , isDecimal
  , isInteger   :: String -> Bool

isLanguage :: DatatypeName -> Bool
isLanguage      = GenRegex DatatypeName -> DatatypeName -> Bool
forall s. StringLike s => GenRegex s -> s -> Bool
matchRE GenRegex DatatypeName
rexLanguage
isHexBinary :: DatatypeName -> Bool
isHexBinary     = GenRegex DatatypeName -> DatatypeName -> Bool
forall s. StringLike s => GenRegex s -> s -> Bool
matchRE GenRegex DatatypeName
rexHexBinary
isBase64Binary :: DatatypeName -> Bool
isBase64Binary  = GenRegex DatatypeName -> DatatypeName -> Bool
forall s. StringLike s => GenRegex s -> s -> Bool
matchRE GenRegex DatatypeName
rexBase64Binary
isDecimal :: DatatypeName -> Bool
isDecimal       = GenRegex DatatypeName -> DatatypeName -> Bool
forall s. StringLike s => GenRegex s -> s -> Bool
matchRE GenRegex DatatypeName
rexDecimal
isInteger :: DatatypeName -> Bool
isInteger       = GenRegex DatatypeName -> DatatypeName -> Bool
forall s. StringLike s => GenRegex s -> s -> Bool
matchRE GenRegex DatatypeName
rexInteger

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

normBase64      :: String -> String
normBase64 :: DatatypeName -> DatatypeName
normBase64      = (Char -> Bool) -> DatatypeName -> DatatypeName
forall a. (a -> Bool) -> [a] -> [a]
filter Char -> Bool
isB64
                  where
                  isB64 :: Char -> Bool
isB64 Char
c = ( Char
'A' Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
c Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'Z')
                            Bool -> Bool -> Bool
||
                            ( Char
'a' Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
c Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'z')
                            Bool -> Bool -> Bool
||
                            ( Char
'0' Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
c Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'9')
                            Bool -> Bool -> Bool
||
                            Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'+'
                            Bool -> Bool -> Bool
||
                            Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/'
                            Bool -> Bool -> Bool
||
                            Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'='

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

readDecimal
  , readDecimal'        :: String -> Rational

readDecimal :: DatatypeName -> Rational
readDecimal (Char
'+':DatatypeName
s)     = DatatypeName -> Rational
readDecimal' DatatypeName
s
readDecimal (Char
'-':DatatypeName
s)     = Rational -> Rational
forall a. Num a => a -> a
negate (DatatypeName -> Rational
readDecimal' DatatypeName
s)
readDecimal      DatatypeName
s      = DatatypeName -> Rational
readDecimal' DatatypeName
s

readDecimal' :: DatatypeName -> Rational
readDecimal' DatatypeName
s
    | Integer
f Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0    = (Integer
n Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Integer
1)
    | Bool
otherwise = (Integer
n Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Integer
1) Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
+ (Integer
f Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% (Integer
10 Integer -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ (Int -> Integer
forall a. Integral a => a -> Integer
toInteger (DatatypeName -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length DatatypeName
fs))))
    where
    (DatatypeName
ns, DatatypeName
fs') = (Char -> Bool) -> DatatypeName -> (DatatypeName, DatatypeName)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'.') DatatypeName
s
    fs :: DatatypeName
fs = Int -> DatatypeName -> DatatypeName
forall a. Int -> [a] -> [a]
drop Int
1 DatatypeName
fs'

    f :: Integer
    f :: Integer
f | DatatypeName -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null DatatypeName
fs         = Integer
0
      | Bool
otherwise       = DatatypeName -> Integer
forall a. Read a => DatatypeName -> a
read DatatypeName
fs
    n :: Integer
    n :: Integer
n | DatatypeName -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null DatatypeName
ns         = Integer
0
      | Bool
otherwise       = DatatypeName -> Integer
forall a. Read a => DatatypeName -> a
read DatatypeName
ns

totalDigits
  , totalDigits'
  , fractionDigits      :: Rational -> Int

totalDigits :: Rational -> Int
totalDigits Rational
r
    | Rational
r Rational -> Rational -> Bool
forall a. Eq a => a -> a -> Bool
== Rational
0                    = Int
0
    | Rational
r Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
< Rational
0                     = Rational -> Int
totalDigits' (Rational -> Int) -> (Rational -> Rational) -> Rational -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rational -> Rational
forall a. Num a => a -> a
negate  (Rational -> Int) -> Rational -> Int
forall a b. (a -> b) -> a -> b
$ Rational
r
    | Bool
otherwise                 = Rational -> Int
totalDigits'           (Rational -> Int) -> Rational -> Int
forall a b. (a -> b) -> a -> b
$ Rational
r

totalDigits' :: Rational -> Int
totalDigits' Rational
r
    | Rational -> Integer
forall a. Ratio a -> a
denominator Rational
r Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
1        = DatatypeName -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (DatatypeName -> Int)
-> (Rational -> DatatypeName) -> Rational -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> DatatypeName
forall a. Show a => a -> DatatypeName
show (Integer -> DatatypeName)
-> (Rational -> Integer) -> Rational -> DatatypeName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rational -> Integer
forall a. Ratio a -> a
numerator  (Rational -> Int) -> Rational -> Int
forall a b. (a -> b) -> a -> b
$ Rational
r
    | Rational
r Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
< (Integer
1Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
%Integer
1)                 = (\ Int
x -> Int
xInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) (Int -> Int) -> (Rational -> Int) -> Rational -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rational -> Int
totalDigits' (Rational -> Int) -> (Rational -> Rational) -> Rational -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
+ (Integer
1Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
%Integer
1))    (Rational -> Int) -> Rational -> Int
forall a b. (a -> b) -> a -> b
$ Rational
r
    | Bool
otherwise                 = Rational -> Int
totalDigits' (Rational -> Int) -> (Rational -> Rational) -> Rational -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* (Integer
10 Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Integer
1)) (Rational -> Int) -> Rational -> Int
forall a b. (a -> b) -> a -> b
$ Rational
r

fractionDigits :: Rational -> Int
fractionDigits Rational
r
    | Rational -> Integer
forall a. Ratio a -> a
denominator Rational
r Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
1        = Int
0
    | Bool
otherwise                 = (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (Int -> Int) -> (Rational -> Int) -> Rational -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rational -> Int
fractionDigits (Rational -> Int) -> (Rational -> Rational) -> Rational -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* (Integer
10 Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Integer
1)) (Rational -> Int) -> Rational -> Int
forall a b. (a -> b) -> a -> b
$ Rational
r

showDecimal
  , showDecimal'                :: Rational -> String

showDecimal :: Rational -> DatatypeName
showDecimal Rational
d
    | Rational
d Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
< Rational
0     = (Char
'-'Char -> DatatypeName -> DatatypeName
forall a. a -> [a] -> [a]
:) (DatatypeName -> DatatypeName)
-> (Rational -> DatatypeName) -> Rational -> DatatypeName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rational -> DatatypeName
showDecimal' (Rational -> DatatypeName)
-> (Rational -> Rational) -> Rational -> DatatypeName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rational -> Rational
forall a. Num a => a -> a
negate    (Rational -> DatatypeName) -> Rational -> DatatypeName
forall a b. (a -> b) -> a -> b
$ Rational
d
    | Rational
d Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
< Rational
1     = Int -> DatatypeName -> DatatypeName
forall a. Int -> [a] -> [a]
drop Int
1 (DatatypeName -> DatatypeName)
-> (Rational -> DatatypeName) -> Rational -> DatatypeName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rational -> DatatypeName
showDecimal' (Rational -> DatatypeName)
-> (Rational -> Rational) -> Rational -> DatatypeName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
+ (Integer
1Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
%Integer
1)) (Rational -> DatatypeName) -> Rational -> DatatypeName
forall a b. (a -> b) -> a -> b
$ Rational
d
    | Bool
otherwise =          Rational -> DatatypeName
showDecimal'             (Rational -> DatatypeName) -> Rational -> DatatypeName
forall a b. (a -> b) -> a -> b
$ Rational
d

showDecimal' :: Rational -> DatatypeName
showDecimal' Rational
d
    | Rational -> Integer
forall a. Ratio a -> a
denominator Rational
d Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
1        = Integer -> DatatypeName
forall a. Show a => a -> DatatypeName
show (Integer -> DatatypeName)
-> (Rational -> Integer) -> Rational -> DatatypeName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rational -> Integer
forall a. Ratio a -> a
numerator (Rational -> DatatypeName) -> Rational -> DatatypeName
forall a b. (a -> b) -> a -> b
$ Rational
d
    | Bool
otherwise                 = Int -> Rational -> DatatypeName
forall {a}. (Integral a, Show a) => Int -> Ratio a -> DatatypeName
times10 Int
0        (Rational -> DatatypeName) -> Rational -> DatatypeName
forall a b. (a -> b) -> a -> b
$ Rational
d
    where
    times10 :: Int -> Ratio a -> DatatypeName
times10 Int
i' Ratio a
d'
        | Ratio a -> a
forall a. Ratio a -> a
denominator Ratio a
d' a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
1   = let
                                  (DatatypeName
x, DatatypeName
y) = Int -> DatatypeName -> (DatatypeName, DatatypeName)
forall a. Int -> [a] -> ([a], [a])
splitAt Int
i' (DatatypeName -> (DatatypeName, DatatypeName))
-> (Ratio a -> DatatypeName)
-> Ratio a
-> (DatatypeName, DatatypeName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DatatypeName -> DatatypeName
forall a. [a] -> [a]
reverse (DatatypeName -> DatatypeName)
-> (Ratio a -> DatatypeName) -> Ratio a -> DatatypeName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> DatatypeName
forall a. Show a => a -> DatatypeName
show (a -> DatatypeName) -> (Ratio a -> a) -> Ratio a -> DatatypeName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ratio a -> a
forall a. Ratio a -> a
numerator (Ratio a -> (DatatypeName, DatatypeName))
-> Ratio a -> (DatatypeName, DatatypeName)
forall a b. (a -> b) -> a -> b
$ Ratio a
d'
                                  in
                                  DatatypeName -> DatatypeName
forall a. [a] -> [a]
reverse DatatypeName
y DatatypeName -> DatatypeName -> DatatypeName
forall a. [a] -> [a] -> [a]
++ DatatypeName
"." DatatypeName -> DatatypeName -> DatatypeName
forall a. [a] -> [a] -> [a]
++ DatatypeName -> DatatypeName
forall a. [a] -> [a]
reverse DatatypeName
x
        | Bool
otherwise             = Int -> Ratio a -> DatatypeName
times10 (Int
i' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Ratio a
d' Ratio a -> Ratio a -> Ratio a
forall a. Num a => a -> a -> a
* (a
10 a -> a -> Ratio a
forall a. Integral a => a -> a -> Ratio a
% a
1))

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

-- | Tests whether a XML instance value matches a data-pattern.
-- (see also: 'stringValid')

datatypeAllowsW3C :: DatatypeAllows
datatypeAllowsW3C :: DatatypeAllows
datatypeAllowsW3C DatatypeName
d ParamList
params DatatypeName
value Context
_
    = CheckString -> DatatypeName -> Maybe DatatypeName
forall a b. CheckA a b -> a -> Maybe DatatypeName
performCheck CheckString
check DatatypeName
value
    where
    validString :: (DatatypeName -> DatatypeName) -> CheckString
validString DatatypeName -> DatatypeName
normFct
        = CheckString
validPattern
          CheckString -> CheckString -> CheckString
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
          (DatatypeName -> DatatypeName) -> CheckString
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr DatatypeName -> DatatypeName
normFct
          CheckString -> CheckString -> CheckString
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
          CheckString
validLength

    validNormString :: CheckString
validNormString
        = (DatatypeName -> DatatypeName) -> CheckString
validString DatatypeName -> DatatypeName
normalizeWhitespace

    validPattern :: CheckString
validPattern
        = ParamList -> CheckString
patternValid ParamList
params

    validLength :: CheckString
validLength
        = DatatypeName -> Integer -> Integer -> ParamList -> CheckString
stringValid DatatypeName
d Integer
0 (-Integer
1) ParamList
params

    validList :: CheckString
validList
        = CheckString
validPattern
          CheckString -> CheckString -> CheckString
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
          (DatatypeName -> DatatypeName) -> CheckString
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr DatatypeName -> DatatypeName
normalizeWhitespace
          CheckString -> CheckString -> CheckString
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
          CheckString
validListLength

    validListLength :: CheckString
validListLength
        = DatatypeName -> ParamList -> CheckString
listValid DatatypeName
d ParamList
params

    validName :: (DatatypeName -> Bool) -> CheckString
validName DatatypeName -> Bool
isN
        = (DatatypeName -> Bool) -> CheckString
assertW3C DatatypeName -> Bool
isN

    validNCName :: CheckString
validNCName
        = CheckString
validNormString CheckString -> CheckString -> CheckString
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (DatatypeName -> Bool) -> CheckString
validName DatatypeName -> Bool
isNCName

    validQName :: CheckString
validQName
        = CheckString
validNormString CheckString -> CheckString -> CheckString
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (DatatypeName -> Bool) -> CheckString
validName DatatypeName -> Bool
isWellformedQualifiedName

    validDecimal :: CheckString
validDecimal
        = (DatatypeName -> DatatypeName) -> CheckString
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr DatatypeName -> DatatypeName
normalizeWhitespace
          CheckString -> CheckString -> CheckString
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
          (DatatypeName -> Bool) -> CheckString
assertW3C DatatypeName -> Bool
isDecimal
          CheckString -> CheckString -> CheckString
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
          (DatatypeName -> Rational)
-> CheckA Rational Rational -> CheckString
forall a b c. (a -> b) -> CheckA b c -> CheckA a a
checkWith DatatypeName -> Rational
readDecimal (ParamList -> CheckA Rational Rational
decimalValid ParamList
params)

    validInteger :: DatatypeName -> CheckString
validInteger DatatypeName
inRange
        = CheckString
validPattern
          CheckString -> CheckString -> CheckString
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
          (DatatypeName -> DatatypeName) -> CheckString
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr DatatypeName -> DatatypeName
normalizeWhitespace
          CheckString -> CheckString -> CheckString
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
          (DatatypeName -> Bool) -> CheckString
assertW3C DatatypeName -> Bool
isInteger
          CheckString -> CheckString -> CheckString
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
          (DatatypeName -> Integer) -> CheckA Integer Integer -> CheckString
forall a b c. (a -> b) -> CheckA b c -> CheckA a a
checkWith DatatypeName -> Integer
forall a. Read a => DatatypeName -> a
read (DatatypeName -> ParamList -> CheckA Integer Integer
integerValid DatatypeName
inRange ParamList
params)

    check       :: CheckString
    check :: CheckString
check       = CheckString -> Maybe CheckString -> CheckString
forall a. a -> Maybe a -> a
fromMaybe CheckString
forall {b}. CheckA DatatypeName b
notFound (Maybe CheckString -> CheckString)
-> ([(DatatypeName, CheckString)] -> Maybe CheckString)
-> [(DatatypeName, CheckString)]
-> CheckString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DatatypeName -> [(DatatypeName, CheckString)] -> Maybe CheckString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup DatatypeName
d ([(DatatypeName, CheckString)] -> CheckString)
-> [(DatatypeName, CheckString)] -> CheckString
forall a b. (a -> b) -> a -> b
$ [(DatatypeName, CheckString)]
checks

    notFound :: CheckA DatatypeName b
notFound    = (DatatypeName -> DatatypeName) -> CheckA DatatypeName b
forall a b. (a -> DatatypeName) -> CheckA a b
failure ((DatatypeName -> DatatypeName) -> CheckA DatatypeName b)
-> (DatatypeName -> DatatypeName) -> CheckA DatatypeName b
forall a b. (a -> b) -> a -> b
$ DatatypeName
-> DatatypeName -> ParamList -> DatatypeName -> DatatypeName
errorMsgDataTypeNotAllowed DatatypeName
w3cNS DatatypeName
d ParamList
params

    checks      :: [(String, CheckA String String)]
    checks :: [(DatatypeName, CheckString)]
checks      = [ (DatatypeName
xsd_string,                (DatatypeName -> DatatypeName) -> CheckString
validString DatatypeName -> DatatypeName
forall a. a -> a
id)
                  , (DatatypeName
xsd_normalizedString,      (DatatypeName -> DatatypeName) -> CheckString
validString DatatypeName -> DatatypeName
normalizeBlanks)
                  , (DatatypeName
xsd_token,                 CheckString
validNormString)
                  , (DatatypeName
xsd_language,              CheckString
validNormString CheckString -> CheckString -> CheckString
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (DatatypeName -> Bool) -> CheckString
assertW3C DatatypeName -> Bool
isLanguage)
                  , (DatatypeName
xsd_NMTOKEN,               CheckString
validNormString CheckString -> CheckString -> CheckString
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (DatatypeName -> Bool) -> CheckString
validName DatatypeName -> Bool
isNmtoken)
                  , (DatatypeName
xsd_NMTOKENS,              CheckString
validList       CheckString -> CheckString -> CheckString
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (DatatypeName -> Bool) -> CheckString
validName ((DatatypeName -> Bool) -> DatatypeName -> Bool
isNameList DatatypeName -> Bool
isNmtoken))
                  , (DatatypeName
xsd_Name,                  CheckString
validNormString CheckString -> CheckString -> CheckString
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (DatatypeName -> Bool) -> CheckString
validName DatatypeName -> Bool
isName)
                  , (DatatypeName
xsd_NCName,                CheckString
validNCName)
                  , (DatatypeName
xsd_ID,                    CheckString
validNCName)
                  , (DatatypeName
xsd_IDREF,                 CheckString
validNCName)
                  , (DatatypeName
xsd_IDREFS,                CheckString
validList       CheckString -> CheckString -> CheckString
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (DatatypeName -> Bool) -> CheckString
validName ((DatatypeName -> Bool) -> DatatypeName -> Bool
isNameList DatatypeName -> Bool
isNCName))
                  , (DatatypeName
xsd_ENTITY,                CheckString
validNCName)
                  , (DatatypeName
xsd_ENTITIES,              CheckString
validList       CheckString -> CheckString -> CheckString
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (DatatypeName -> Bool) -> CheckString
validName ((DatatypeName -> Bool) -> DatatypeName -> Bool
isNameList DatatypeName -> Bool
isNCName))
                  , (DatatypeName
xsd_anyURI,                (DatatypeName -> Bool) -> CheckString
validName DatatypeName -> Bool
isURIReference CheckString -> CheckString -> CheckString
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (DatatypeName -> DatatypeName) -> CheckString
validString DatatypeName -> DatatypeName
escapeURI)
                  , (DatatypeName
xsd_QName,                 CheckString
validQName)
                  , (DatatypeName
xsd_NOTATION,              CheckString
validQName)
                  , (DatatypeName
xsd_hexBinary,             (DatatypeName -> DatatypeName) -> CheckString
validString DatatypeName -> DatatypeName
forall a. a -> a
id         CheckString -> CheckString -> CheckString
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (DatatypeName -> Bool) -> CheckString
assertW3C DatatypeName -> Bool
isHexBinary)
                  , (DatatypeName
xsd_base64Binary,          (DatatypeName -> DatatypeName) -> CheckString
validString DatatypeName -> DatatypeName
normBase64 CheckString -> CheckString -> CheckString
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (DatatypeName -> Bool) -> CheckString
assertW3C DatatypeName -> Bool
isBase64Binary)
                  , (DatatypeName
xsd_decimal,               CheckString
validPattern CheckString -> CheckString -> CheckString
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> CheckString
validDecimal)
                  , (DatatypeName
xsd_integer,               DatatypeName -> CheckString
validInteger DatatypeName
xsd_integer)
                  , (DatatypeName
xsd_nonPositiveInteger,    DatatypeName -> CheckString
validInteger DatatypeName
xsd_nonPositiveInteger)
                  , (DatatypeName
xsd_negativeInteger,       DatatypeName -> CheckString
validInteger DatatypeName
xsd_negativeInteger)
                  , (DatatypeName
xsd_nonNegativeInteger,    DatatypeName -> CheckString
validInteger DatatypeName
xsd_nonNegativeInteger)
                  , (DatatypeName
xsd_positiveInteger,       DatatypeName -> CheckString
validInteger DatatypeName
xsd_positiveInteger)
                  , (DatatypeName
xsd_long,                  DatatypeName -> CheckString
validInteger DatatypeName
xsd_long)
                  , (DatatypeName
xsd_int,                   DatatypeName -> CheckString
validInteger DatatypeName
xsd_int)
                  , (DatatypeName
xsd_short,                 DatatypeName -> CheckString
validInteger DatatypeName
xsd_short)
                  , (DatatypeName
xsd_byte,                  DatatypeName -> CheckString
validInteger DatatypeName
xsd_byte)
                  , (DatatypeName
xsd_unsignedLong,          DatatypeName -> CheckString
validInteger DatatypeName
xsd_unsignedLong)
                  , (DatatypeName
xsd_unsignedInt,           DatatypeName -> CheckString
validInteger DatatypeName
xsd_unsignedInt)
                  , (DatatypeName
xsd_unsignedShort,         DatatypeName -> CheckString
validInteger DatatypeName
xsd_unsignedShort)
                  , (DatatypeName
xsd_unsignedByte,          DatatypeName -> CheckString
validInteger DatatypeName
xsd_unsignedByte)
                  ]
    assertW3C :: (DatatypeName -> Bool) -> CheckString
assertW3C DatatypeName -> Bool
p = (DatatypeName -> Bool)
-> (DatatypeName -> DatatypeName) -> CheckString
forall a. (a -> Bool) -> (a -> DatatypeName) -> CheckA a a
assert DatatypeName -> Bool
p DatatypeName -> DatatypeName
errW3C
    errW3C :: DatatypeName -> DatatypeName
errW3C      = DatatypeName -> DatatypeName -> DatatypeName -> DatatypeName
errorMsgDataLibQName DatatypeName
w3cNS DatatypeName
d

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

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

datatypeEqualW3C :: DatatypeEqual
datatypeEqualW3C :: DatatypeEqual
datatypeEqualW3C DatatypeName
d DatatypeName
s1 Context
_ DatatypeName
s2 Context
_
    = CheckA (DatatypeName, DatatypeName) (DatatypeName, DatatypeName)
-> (DatatypeName, DatatypeName) -> Maybe DatatypeName
forall a b. CheckA a b -> a -> Maybe DatatypeName
performCheck CheckA (DatatypeName, DatatypeName) (DatatypeName, DatatypeName)
check (DatatypeName
s1, DatatypeName
s2)
    where
    check       :: CheckA (String, String) (String, String)
    check :: CheckA (DatatypeName, DatatypeName) (DatatypeName, DatatypeName)
check       = CheckA (DatatypeName, DatatypeName) (DatatypeName, DatatypeName)
-> ((DatatypeName -> DatatypeName)
    -> CheckA
         (DatatypeName, DatatypeName) (DatatypeName, DatatypeName))
-> Maybe (DatatypeName -> DatatypeName)
-> CheckA (DatatypeName, DatatypeName) (DatatypeName, DatatypeName)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe CheckA (DatatypeName, DatatypeName) (DatatypeName, DatatypeName)
forall {a} {b}. CheckA a b
notFound (DatatypeName -> DatatypeName)
-> CheckA (DatatypeName, DatatypeName) (DatatypeName, DatatypeName)
forall {t}.
(t -> DatatypeName) -> CheckA (t, t) (DatatypeName, DatatypeName)
found (Maybe (DatatypeName -> DatatypeName)
 -> CheckA
      (DatatypeName, DatatypeName) (DatatypeName, DatatypeName))
-> ([(DatatypeName, DatatypeName -> DatatypeName)]
    -> Maybe (DatatypeName -> DatatypeName))
-> [(DatatypeName, DatatypeName -> DatatypeName)]
-> CheckA (DatatypeName, DatatypeName) (DatatypeName, DatatypeName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DatatypeName
-> [(DatatypeName, DatatypeName -> DatatypeName)]
-> Maybe (DatatypeName -> DatatypeName)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup DatatypeName
d ([(DatatypeName, DatatypeName -> DatatypeName)]
 -> CheckA
      (DatatypeName, DatatypeName) (DatatypeName, DatatypeName))
-> [(DatatypeName, DatatypeName -> DatatypeName)]
-> CheckA (DatatypeName, DatatypeName) (DatatypeName, DatatypeName)
forall a b. (a -> b) -> a -> b
$ [(DatatypeName, DatatypeName -> DatatypeName)]
norm

    notFound :: CheckA a b
notFound    = (a -> DatatypeName) -> CheckA a b
forall a b. (a -> DatatypeName) -> CheckA a b
failure ((a -> DatatypeName) -> CheckA a b)
-> (a -> DatatypeName) -> CheckA a b
forall a b. (a -> b) -> a -> b
$ DatatypeName -> a -> DatatypeName
forall a b. a -> b -> a
const (DatatypeName -> DatatypeName -> DatatypeName
errorMsgDataTypeNotAllowed0 DatatypeName
w3cNS DatatypeName
d)

    found :: (t -> DatatypeName) -> CheckA (t, t) (DatatypeName, DatatypeName)
found t -> DatatypeName
nf    = ((t, t) -> (DatatypeName, DatatypeName))
-> CheckA (t, t) (DatatypeName, DatatypeName)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (\ (t
x1, t
x2) -> (t -> DatatypeName
nf t
x1, t -> DatatypeName
nf t
x2))                    -- normalize both values
                  CheckA (t, t) (DatatypeName, DatatypeName)
-> CheckA (DatatypeName, DatatypeName) (DatatypeName, DatatypeName)
-> CheckA (t, t) (DatatypeName, DatatypeName)
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
                  ((DatatypeName, DatatypeName) -> Bool)
-> ((DatatypeName, DatatypeName) -> DatatypeName)
-> CheckA (DatatypeName, DatatypeName) (DatatypeName, DatatypeName)
forall a. (a -> Bool) -> (a -> DatatypeName) -> CheckA a a
assert ((DatatypeName -> DatatypeName -> Bool)
-> (DatatypeName, DatatypeName) -> Bool
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry DatatypeName -> DatatypeName -> Bool
forall a. Eq a => a -> a -> Bool
(==)) ((DatatypeName -> DatatypeName -> DatatypeName)
-> (DatatypeName, DatatypeName) -> DatatypeName
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((DatatypeName -> DatatypeName -> DatatypeName)
 -> (DatatypeName, DatatypeName) -> DatatypeName)
-> (DatatypeName -> DatatypeName -> DatatypeName)
-> (DatatypeName, DatatypeName)
-> DatatypeName
forall a b. (a -> b) -> a -> b
$ DatatypeName -> DatatypeName -> DatatypeName -> DatatypeName
errorMsgEqual DatatypeName
d)     -- and check on (==)

    norm :: [(DatatypeName, DatatypeName -> DatatypeName)]
norm = [ (DatatypeName
xsd_string,               DatatypeName -> DatatypeName
forall a. a -> a
id                      )
           , (DatatypeName
xsd_normalizedString,     DatatypeName -> DatatypeName
normalizeBlanks         )
           , (DatatypeName
xsd_token,                DatatypeName -> DatatypeName
normalizeWhitespace     )
           , (DatatypeName
xsd_language,             DatatypeName -> DatatypeName
normalizeWhitespace     )
           , (DatatypeName
xsd_NMTOKEN,              DatatypeName -> DatatypeName
normalizeWhitespace     )
           , (DatatypeName
xsd_NMTOKENS,             DatatypeName -> DatatypeName
normalizeWhitespace     )
           , (DatatypeName
xsd_Name,                 DatatypeName -> DatatypeName
normalizeWhitespace     )
           , (DatatypeName
xsd_NCName,               DatatypeName -> DatatypeName
normalizeWhitespace     )
           , (DatatypeName
xsd_ID,                   DatatypeName -> DatatypeName
normalizeWhitespace     )
           , (DatatypeName
xsd_IDREF,                DatatypeName -> DatatypeName
normalizeWhitespace     )
           , (DatatypeName
xsd_IDREFS,               DatatypeName -> DatatypeName
normalizeWhitespace     )
           , (DatatypeName
xsd_ENTITY,               DatatypeName -> DatatypeName
normalizeWhitespace     )
           , (DatatypeName
xsd_ENTITIES,             DatatypeName -> DatatypeName
normalizeWhitespace     )
           , (DatatypeName
xsd_anyURI,               DatatypeName -> DatatypeName
escapeURI (DatatypeName -> DatatypeName)
-> (DatatypeName -> DatatypeName) -> DatatypeName -> DatatypeName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DatatypeName -> DatatypeName
normalizeWhitespace )
           , (DatatypeName
xsd_QName,                DatatypeName -> DatatypeName
normalizeWhitespace     )
           , (DatatypeName
xsd_NOTATION,             DatatypeName -> DatatypeName
normalizeWhitespace     )
           , (DatatypeName
xsd_hexBinary,            DatatypeName -> DatatypeName
forall a. a -> a
id                      )
           , (DatatypeName
xsd_base64Binary,         DatatypeName -> DatatypeName
normBase64              )
           , (DatatypeName
xsd_decimal,              Rational -> DatatypeName
forall a. Show a => a -> DatatypeName
show (Rational -> DatatypeName)
-> (DatatypeName -> Rational) -> DatatypeName -> DatatypeName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DatatypeName -> Rational
readDecimal (DatatypeName -> Rational)
-> (DatatypeName -> DatatypeName) -> DatatypeName -> Rational
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DatatypeName -> DatatypeName
normalizeWhitespace        )
           ]

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