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

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