Nahive validation Monad

Validator.hs

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