content: -- |
  -- exports helper functions for the integration of new datatype-libraries
  
  module Text.XML.HXT.RelaxNG.DataTypeLibUtils
    ( errorMsgEqual
    , errorMsgDataTypeNotAllowed
    , errorMsgDataTypeNotAllowed0
    , errorMsgDataTypeNotAllowed2
    , errorMsgDataLibQName
    , errorMsgParam
  
    , rng_length
    , rng_maxLength
    , rng_minLength
     ,rng_maxExclusive
    , rng_minExclusive
    , rng_maxInclusive
    , rng_minInclusive
  
    , module Control.Arrow
    , module Text.XML.HXT.DOM.Util
    , module Text.XML.HXT.RelaxNG.Utils
    , module Text.XML.HXT.RelaxNG.DataTypes
  
    , FunctionTable
  
    , stringValidFT       -- generalized checkString
    , fctTableString      -- minLength, maxLenght, length
    , fctTableList        -- minLength, maxLenght, length
  
    , stringValid         -- checkString
    , numberValid         -- checkNumeric
  
    , numParamValid
  
    , CheckA              -- Check datatype
    , CheckString         -- CheckA String String
    , CheckInteger        -- CheckA Integer Integer
  
    , performCheck        -- run a CheckA
    , ok                  -- always true
    , failure             -- create an error meesage
    , assert              -- create a primitive check from a predicate
    , assertMaybe         -- create a primitive check from a maybe
    , checkWith           -- convert value before checking
    )
  
  where
  import Prelude hiding (id, (.))
  
  import Control.Category
  import Control.Arrow
  
  import Data.Maybe
  
  import Text.XML.HXT.DOM.Util
  
  import Text.XML.HXT.RelaxNG.DataTypes
  import Text.XML.HXT.RelaxNG.Utils
  
  -- ------------------------------------------------------------
  
  newtype CheckA a b      = C { runCheck :: a -> Either String b }
  
  instance Category CheckA where
      id          = C $ Right
  
      f2 . f1     = C $                           -- logical and: f1 and f2 must hold
                    \ x -> case runCheck f1 x of
                           Right y        -> runCheck f2 y
                           Left  e        -> Left e
  
  instance Arrow CheckA where
      arr f       = C ( Right . f )               -- unit: no check, always o.k., just a conversion
  
      first f1    = C $                           -- check 1. component of a pair
                    \ ~(x1, x2) -> case runCheck f1 x1 of
                                   Right y1       -> Right (y1, x2)
                                   Left  e        -> Left  e
  
      second f2   = C $                           -- check 2. component of a pair
                    \ ~(x1, x2) -> case runCheck f2 x2 of
                                   Right y2       -> Right (x1, y2)
                                   Left  e        -> Left  e
  
  
  
  instance ArrowZero CheckA where
      zeroArrow   = C $ const (Left "")           -- always false: zero
  
  instance ArrowPlus CheckA where
      f1 <+> f2   = C $                           -- logical or
                    \ x -> case runCheck f1 x of
                           Right y1       -> Right y1
                           Left  e1       -> case runCheck f2 x of
                                             Right y2     -> Right y2
                                             Left  e2     -> Left ( if null e1
                                                                    then e2
                                                                    else
                                                                    if null e2
                                                                    then e1
                                                                    else e1 ++ " or " ++ e2
                                                                  )
  
  type CheckString        = CheckA String String
  type CheckInteger       = CheckA Integer Integer
  
  -- | run a check and deliver Just an error message or Nothing
  
  performCheck    :: CheckA a b -> a -> Maybe String
  performCheck c  = either Just (const Nothing) . runCheck c
  
  -- | always failure
  
  failure         :: (a -> String) -> CheckA a b
  failure msg     = C (Left . msg)
  
  -- | every thing is fine
  
  ok              :: CheckA a a
  ok              = arr id
  
  -- | perform a simple check with a predicate p,
  --   when the predicate holds, assert acts as identity,
  --   else an error message is generated
  
  assert  :: (a -> Bool) -> (a -> String) -> CheckA a a
  assert p msg    = C $ \ x -> if p x then Right x else Left (msg x)
  
  -- | perform a simple check with a Maybe function, Nothing indicates error
  
  assertMaybe     :: (a -> Maybe b) -> (a -> String) -> CheckA a b
  assertMaybe f msg
      = C $ \ x -> case f x of
                   Nothing        -> Left (msg x)
                   Just y         -> Right y
  
  -- | perform a check, but convert the value before checking
  
  checkWith       :: (a -> b) -> CheckA b c -> CheckA a a
  checkWith f c   = C $
                    \ x -> case runCheck c (f x) of
                           Right _        -> Right x
                           Left  e        -> Left  e
  
  -- ------------------------------------------------------------
  
  -- RelaxNG attribute names
  
  rng_length, rng_maxLength, rng_minLength
   ,rng_maxExclusive, rng_minExclusive, rng_maxInclusive, rng_minInclusive :: String
  
  rng_length              = "length"
  rng_maxLength           = "maxLength"
  rng_minLength           = "minLength"
  
  rng_maxExclusive        = "maxExclusive"
  rng_minExclusive        = "minExclusive"
  rng_maxInclusive        = "maxInclusive"
  rng_minInclusive        = "minInclusive"
  
  -- ------------------------------------------------------------
  
  -- | Function table type
  
  type FunctionTable      = [(String, String -> String -> Bool)]
  
  -- | Function table for numeric tests,
  -- XML document value is first operand, schema value second
  
  fctTableNum :: (Ord a, Num a) => [(String, a -> a -> Bool)]
  fctTableNum
      = [ (rng_maxExclusive, (<))
        , (rng_minExclusive, (>))
        , (rng_maxInclusive, (<=))
        , (rng_minInclusive, (>=))
        ]
  
  -- | Function table for string tests,
  -- XML document value is first operand, schema value second
  fctTableString :: FunctionTable
  fctTableString
      = [ (rng_length,    (numParamValid (==)))
        , (rng_maxLength, (numParamValid (<=)))
        , (rng_minLength, (numParamValid (>=)))
        ]
  
  -- | Function table for list tests,
  -- XML document value is first operand, schema value second
  
  fctTableList :: FunctionTable
  fctTableList
      = [ (rng_length,    (listParamValid (==)))
        , (rng_maxLength, (listParamValid (<=)))
        , (rng_minLength, (listParamValid (>=)))
        ]
  
  {- |
  tests whether a string value matches a numeric param
  
  valid example:
  
  > <data type="CHAR"> <param name="maxLength">5</param> </data>
  
  invalid example:
  
  > <data type="CHAR"> <param name="minLength">foo</param> </data>
  
  -}
  
  numParamValid :: (Integer -> Integer -> Bool) -> String -> String -> Bool
  numParamValid fct a b
    = isNumber b
      &&
      ( toInteger (length a) `fct` (read b) )
  
  {- |
  tests whether a list value matches a length constraint
  
  valid example:
  
  > <data type="IDREFS"> <param name="maxLength">5</param> </data>
  
  invalid example:
  
  > <data type="IDREFS"> <param name="minLength">foo</param> </data>
  
  -}
  
  listParamValid :: (Integer -> Integer -> Bool) -> String -> String -> Bool
  listParamValid fct a b
    = isNumber b
      &&
      ( toInteger (length . words $ a) `fct` (read b) )
  
  -- ------------------------------------------------------------
  -- new check functions
  
  {- |
  Tests whether a \"string\" datatype value is between the lower and
  upper bound of the datatype and matches all parameters.
  
  All tests are performed on the string value.
  
     * 1.parameter  :  datatype
  
     - 2.parameter  :  lower bound of the datatype range
  
     - 3.parameter  :  upper bound of the datatype range (-1 = no upper bound)
  
     - 4.parameter  :  list of parameters
  
     - 5.parameter  :  datatype value to be checked
  
     - return : Just \"Errormessage\" in case of an error, else Nothing
  
  -}
  
  stringValid     :: DatatypeName -> Integer -> Integer -> ParamList -> CheckString
  stringValid     = stringValidFT fctTableString
  
  stringValidFT :: FunctionTable -> DatatypeName -> Integer -> Integer -> ParamList -> CheckString
  stringValidFT ft datatype lowerBound upperBound params
      = assert boundsOK boundsErr
        >>>
        paramsStringValid params
      where
      boundsOK v
          = ( (lowerBound == 0)
              ||
              (toInteger (length v) >= lowerBound)
            )
            &&
            ( (upperBound == (-1))
              ||
              (toInteger (length v) <= upperBound)
            )
  
      boundsErr v
          = "Length of " ++ v
            ++ " (" ++ (show $ length v) ++ " chars) out of range: "
            ++ show lowerBound ++ " .. " ++ show upperBound
            ++ " for datatype " ++ datatype
  
      paramStringValid :: (LocalName, String) -> CheckString
      paramStringValid (pn, pv)
          = assert paramOK (errorMsgParam pn pv)
            where
            paramOK v  = paramFct pn v pv
            paramFct n = fromMaybe (const . const $ True) $ lookup n ft
  
      paramsStringValid :: ParamList -> CheckString
      paramsStringValid
          = foldr (>>>) ok . map paramStringValid
  
  -- ------------------------------------------------------------
  
  {- |
  Tests whether a \"numeric\" datatype value is between the lower and upper
  bound of the datatype and matches all parameters.
  
  First, the string value is parsed into a numeric representation.
  If no error occur, all following tests are performed on the numeric value.
  
     * 1.parameter  :  datatype
  
     - 2.parameter  :  lower bound of the datatype range
  
     - 3.parameter  :  upper bound of the datatype range (-1 = no upper bound)
  
     - 4.parameter  :  list of parameters
  
     - 5.parameter  :  datatype value to be checked
  
     - return : Just \"Errormessage\" in case of an error, else Nothing
  
  -}
  
  numberValid :: DatatypeName -> Integer -> Integer -> ParamList -> CheckString
  numberValid datatype lowerBound upperBound params
      = assert isNumber numErr
        >>>
        checkWith read ( assert inRange rangeErr
                         >>>
                         paramsNumValid params
                       )
      where
      inRange     :: Integer -> Bool
      inRange x   = x >= lowerBound
                    &&
                    x <= upperBound
  
      rangeErr v  = ( "Value = " ++ show v ++ " out of range: "
                      ++ show lowerBound ++ " .. " ++ show upperBound
                      ++ " for datatype " ++ datatype
                    )
      numErr v
          = "Value = " ++ v ++ " is not a number"
  
  paramsNumValid  :: ParamList -> CheckInteger
  paramsNumValid
      = foldr (>>>) ok . map paramNumValid
  
  paramNumValid   :: (LocalName, String) -> CheckInteger
  paramNumValid (pn, pv)
      = assert paramOK (errorMsgParam pn pv . show)
      where
      paramOK  v = isNumber pv
                   &&
                   paramFct pn v (read pv)
      paramFct n = fromJust $ lookup n fctTableNum
  
  -- ------------------------------------------------------------
  
  {- |
  Error Message for the equality test of two datatype values
  
     * 1.parameter  :  datatype
  
     - 2.parameter  :  datatype value
  
     - 3.parameter  :  datatype value
  
  example:
  
  > errorMsgEqual "Int" "21" "42" -> "Datatype Int with value = 21 expected, but value = 42 found"
  
  -}
  
  errorMsgParam   :: LocalName -> String -> String -> String
  errorMsgParam pn pv v
      = ( "Parameter restriction: \""
          ++ pn ++ " = " ++ pv
          ++ "\" does not hold for value = \"" ++ v ++ "\""
        )
  
  errorMsgEqual :: DatatypeName -> String -> String -> String
  errorMsgEqual d s1 s2
      = ( "Datatype" ++ show d ++
          " with value = " ++ show s1 ++
          " expected, but value = " ++ show s2 ++ " found"
        )
  errorMsgDataTypeNotAllowed :: String -> String -> [(String, String)] -> String -> String
  errorMsgDataTypeNotAllowed l t p v
      = ( "Datatype " ++ show t ++ " with parameter(s) " ++
          formatStringListPairs p ++ " and value = " ++ show v ++
          " not allowed for DatatypeLibrary " ++ show l
        )
  
  errorMsgDataTypeNotAllowed0 :: String -> String -> String
  errorMsgDataTypeNotAllowed0 l t
      = ( "Datatype " ++ show t ++
          " not allowed for DatatypeLibrary " ++ show l
        )
  errorMsgDataTypeNotAllowed2 :: String -> String -> String -> String -> String
  errorMsgDataTypeNotAllowed2 l t v1 v2
      = ( "Datatype " ++ show t ++
          " with values = " ++ show v1 ++
          " and " ++ show v2 ++
          " not allowed for DatatypeLibrary " ++ show l
        )
  
  errorMsgDataLibQName :: String -> String -> String -> String
  errorMsgDataLibQName l n v
      = show v ++ " is not a valid " ++ n ++ " for DatatypeLibrary " ++ l
  
  -- ------------------------------------------------------------
  