{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeSynonymInstances #-}
module Data.Menshen(
HasValid(..)
, Validator
, ValidationException(..)
, HasI18n(..)
, HasValidSize(..)
, notNull
, assertNull
, assertTrue
, assertFalse
, positive
, positiveOrZero
, negative
, negativeOrZero
, minInt
, maxInt
, minDecimal
, maxDecimal
, pattern
, email
, (?)
, valify
, (?:)
, (=~)
) where
import Data.Scientific
import qualified Data.Text as TS
import qualified Data.Text.Lazy as TL
import Data.Word
import Text.Regex.TDFA
#if __GLASGOW_HASKELL__ > 708
import Data.Function ((&))
#else
infixl 1 &
(&) :: a -> (a -> b) -> b
x & f = f x
#endif
infixl 5 ?
(?) = (&)
infixl 5 ?:
(?:) :: HasValid m => a -> Validator a -> m a
(?:) = valify
class HasI18n a where
toI18n :: a -> String
data ValidationException
= ShouldBeFalse
| ShouldBeTrue
| ShouldNull
| ShouldNotNull
| InvalidSize Word64 Word64
| InvalidPositive
| InvalidPositiveOrZero
| InvalidNegative
| InvalidNegativeOrZero
| InvalidMax Integer
| InvalidMin Integer
| InvalidEmail
| InvalidNotBlank
| InvalidNotEmpty
| InvalidPast
| InvalidFuture
| InvalidPastOrPresent
| InvalidFutureOrPresent
| InvalidDecimalMax Scientific
| InvalidDecimalMin Scientific
| InvalidDigits Word8 Word8
| InvalidPattern String
deriving Show
instance HasI18n ValidationException where
toI18n ShouldBeTrue = "must be true"
toI18n ShouldBeFalse = "must be false"
toI18n ShouldNull = "must be null"
toI18n ShouldNotNull = "must not be null"
toI18n (InvalidSize a b) = "size must be between " ++ show a ++ " and " ++ show b
toI18n InvalidPositive = "must be greater than 0"
toI18n InvalidPositiveOrZero = "must be greater than or equal to 0"
toI18n InvalidNegative = "must be less than 0"
toI18n InvalidNegativeOrZero = "must be less than or equal to 0"
toI18n InvalidEmail = "must be a well-formed email address"
toI18n InvalidNotBlank = "must not be blank"
toI18n InvalidNotEmpty = "must not be empty"
toI18n InvalidPast = "must be a past date"
toI18n InvalidFuture = "must be a future date"
toI18n InvalidPastOrPresent = "must be a date in the past or in the present"
toI18n InvalidFutureOrPresent = "must be a date in the present or in the future"
toI18n (InvalidMax n) = "must be less than or equal to " ++ show n
toI18n (InvalidMin n) = "must be greater than or equal to " ++ show n
toI18n (InvalidDecimalMax d) = "must be less than " ++ show d
toI18n (InvalidDecimalMin d) = "must be greater than " ++ show d
toI18n (InvalidDigits i f) = "numeric value out of bounds (<" ++ show i ++ " digits>.<" ++ show f ++ " digits> expected)"
toI18n (InvalidPattern r) = "must match " ++ r
class Monad m => HasValid m where
invalid :: HasI18n a => a -> m b
invalid = error . toI18n
instance HasValid (Either String) where
invalid = Left . toI18n
type Validator a = forall m. HasValid m => m a -> m a
class HasValidSize a where
size :: (Word64, Word64) -> Validator a
size (x,y) = \ma -> do
a <- ma
let la = getLength a
if la < x || la > y
then invalid $ InvalidSize x y
else return a
notEmpty :: Validator a
notEmpty = \ma -> do
a <- ma
if getLength a == 0
then invalid InvalidNotEmpty
else return a
notBlank :: Validator a
notBlank = \ma -> do
a <- ma
if getLength a == 0
then invalid InvalidNotBlank
else return a
getLength :: a -> Word64
{-# MINIMAL getLength #-}
instance HasValidSize TS.Text where
getLength = fromIntegral . TS.length
instance HasValidSize TL.Text where
getLength = fromIntegral . TL.length
instance HasValidSize [a] where
getLength = fromIntegral . length
pattern :: RegexLike Regex a => String -> Validator a
pattern p = \ma -> do
a <- ma
if a =~ p then return a
else invalid $ InvalidPattern p
emailPattern :: String
emailPattern = "^[A-Z0-9a-z._%+-]+@[A-Za-z0-9.-]+\\.[A-Za-z]{2,64}$"
email :: RegexLike Regex a => Validator a
email = \ma -> do
a <- ma
if a =~ emailPattern then return a
else invalid InvalidEmail
positive :: (Eq a, Num a) => Validator a
positive = \ma -> do
a <- ma
if a /= 0 && abs a - a == 0
then return a
else invalid InvalidPositive
positiveOrZero :: (Eq a, Num a) => Validator a
positiveOrZero = \ma -> do
a <- ma
if abs a - a == 0
then return a
else invalid InvalidPositiveOrZero
negative :: (Eq a, Num a) => Validator a
negative = \ma -> do
a <- ma
if a /= 0 && abs a + a == 0
then return a
else invalid InvalidNegative
negativeOrZero :: (Eq a, Num a) => Validator a
negativeOrZero = \ma -> do
a <- ma
if abs a + a == 0
then return a
else invalid InvalidNegativeOrZero
assertTrue :: Validator Bool
assertTrue = \ma -> do
a <- ma
if a then return a
else invalid ShouldBeTrue
assertFalse :: Validator Bool
assertFalse = \ma -> do
a <- ma
if not a then return a
else invalid ShouldBeFalse
notNull :: Validator (Maybe a)
notNull = \ma -> do
a <- ma
case a of
Just _ -> return a
_ -> invalid ShouldNotNull
assertNull :: Validator (Maybe a)
assertNull = \ma -> do
a <- ma
case a of
Just _ -> invalid ShouldNull
_ -> return a
maxInt :: Integral a => a -> Validator a
maxInt m = \ma -> do
a <- ma
if a > m
then invalid (InvalidMax $ toInteger m)
else return a
minInt :: Integral a => a -> Validator a
minInt m = \ma -> do
a <- ma
if a < m
then invalid (InvalidMin $ toInteger m)
else return a
maxDecimal :: RealFloat a => a -> Validator a
maxDecimal m = \ma -> do
a <- ma
if a > m
then invalid (InvalidDecimalMax $ fromFloatDigits m)
else return a
minDecimal :: RealFloat a => a -> Validator a
minDecimal m = \ma -> do
a <- ma
if a < m
then invalid (InvalidDecimalMin $ fromFloatDigits m)
else return a
valify :: HasValid m => a -> Validator a -> m a
valify a f = return a ? f