Internal.hs

module Data.JSON2.Internal
  ( -- *  Helpers of check conversion.
    ConvResult
  , checkBoundsIntegral
  , checkBoundsEnum
  , checkInfinite
--  , checkRead
  , ConvError(ConvError)
  , mkError
  , mkError'
  )
where
import Control.Monad.Error
import Data.Typeable

-- Conversion
type ConvResult a = Either ConvError a

-- | Conversion `Rational` number to `Integral` number with check bounds.
checkBoundsIntegral :: (Typeable a, Bounded a, Integral a)
                       => (Rational -> a) -> Rational -> ConvResult a
checkBoundsIntegral f x = do
    let res = f x
    let min = toRational (asTypeOf minBound res)
    let max = toRational (asTypeOf maxBound res)
    if x >= min && x <= max
       then
           return res
       else
           mkError' ("Value must between: (" ++ show min ++ ", "
                       ++ show max ++ ")")  x

-- | Conversion `Rational` number to  `Bounded` values with check bounds.
-- checkBoundsEnum (toEnum . round)
checkBoundsEnum :: (Typeable a, Bounded a, Enum a)
                    => (Rational -> a) -> Rational -> ConvResult a
checkBoundsEnum f x = do
    let x' = fromEnum x
    let res = f x
    let min = fromEnum (asTypeOf minBound res)
    let max = fromEnum (asTypeOf maxBound res)
    if x' >= min && x' <= max
       then
           return res
       else
           mkError' ("Value must between: (" ++ show min ++ ", "
                       ++ show max ++ ")")  x

-- | Conversion `Rational` to `RealFloat` values with check infinity.
checkInfinite :: (Typeable a, RealFloat a)
                  => (Rational -> a) -> Rational -> ConvResult a
checkInfinite f x = do
    let res = f x
    if not (isInfinite res)
       then
           return res
       else
           mkError' "Value conveversion to infinity. "  x

-- | Read whith check.
checkRead :: (Read a, Typeable a) => (ReadS a) -> String -> ConvResult a
checkRead r s = do
     let res = r s
     case res of
       [(x, "")] -> return x
       _         -> mkError' "Read error" s

-- Error Handling

-- | Create  conversion error.
mkError :: (Show a, Typeable a, Typeable b) => a -> ConvResult b
mkError inpval =  mkErrorGen "" inpval undefined

-- | Create  conversion error with message.
mkError' :: (Show a, Typeable a, Typeable b)
             => String -> a -> ConvResult b
mkError' msg inpval =  mkErrorGen msg inpval undefined

mkErrorGen :: (Show a, Typeable a, Typeable b)
              => String -> a -> b -> ConvResult b
mkErrorGen msg inp ret =
    Left ConvError {jsonValue = show inp,
                    jsonType = show . typeOf $ inp,
                    destType = show . typeOf $ ret,
                    errorMessage = msg}

data ConvError = ConvError {
      jsonValue :: String,
      jsonType :: String,
      destType :: String,
      errorMessage :: String}
                    deriving (Eq, Read, Show)

instance Error ConvError where
    strMsg s = ConvError "" "" "" s