Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- {-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving #-}
- import Data.Char
- import Control.Monad
- import Control.Monad.State
- type ErrorMessage = String
- data User = User {
- name :: String
- , age :: Int
- , email :: String
- } deriving (Show)
- data ValidatorState a = ValidatorState {
- subject :: a
- , errors :: [ErrorMessage]
- } deriving (Show)
- newtype ValidatorMonad s a = ValidatorMonad (State (ValidatorState s) a) deriving (Monad, MonadState (ValidatorState s))
- runValidator :: s -> ValidatorMonad s a -> Either [ErrorMessage] s
- runValidator s (ValidatorMonad m) =
- case errorMessages of
- [] -> Right s
- _ -> Left errorMessages
- where
- (_, vs) = runState m (ValidatorState s [])
- errorMessages = errors vs
- getErrors :: ValidatorMonad a [ErrorMessage]
- getErrors = errors `liftM` get
- setErrors :: [ErrorMessage] -> ValidatorMonad a ()
- setErrors es = get >>= \s -> put (s { errors = es })
- modifyErrors :: ([ErrorMessage] -> [ErrorMessage]) -> ValidatorMonad a ()
- modifyErrors fn = setErrors . fn =<< getErrors
- class ModelValidator a where
- validateModel :: ValidatorMonad a ()
- validate :: (a -> Bool) -> ErrorMessage -> ValidatorMonad a ()
- validate p errorMsg = do
- s <- subject `liftM` get
- when ((not . p) s) $ modifyErrors (errorMsg :)
- rangeValidation fieldName fieldMethod start end = do
- let fn n = start < n && n < end
- validate (fn . fieldMethod) (fieldName ++ " must be between " ++ (show start) ++ " and " ++ (show end))
- lowerCaseValidation fieldName fieldMethod = validate (isLowerCase . fieldMethod) (fieldName ++ " must be lowercase")
- where
- isLowerCase = all (\a -> (toLower a) == a)
- instance ModelValidator User where
- validateModel = do
- lowerCaseValidation "Name" name
- rangeValidation "Age" age 0 18
- sampleUser = User "Roman" 25 "romanandreg[at]gmail[dot]com"
- -- runValidation sampleUser validateModel
Add Comment
Please, Sign In to add comment