Validation examples

Main.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
-- Example that shows how to validate a single value
-- with multiple validation functions/smart constructors.

-- Thanks to @purefn for the help on this!

import Control.Applicative
import Control.Lens
import Control.Monad
import Control.Monad.Reader
import Data.List (isInfixOf)
import Data.Validation
import Data.Functor.Compose

-- ***** Types *****
newtype AtString = AtString String deriving (Show)
newtype PeriodString = PeriodString String deriving (Show)
newtype NonEmptyString = NonEmptyString { unNonEmptyString :: String } deriving (Show)

newtype Email = Email String deriving (Show)

data VError = MustNotBeEmpty
            | MustContainAt
            | MustContainPeriod
            deriving (Show)

-- ***** Base smart constructors *****
-- String must contain an '@' character
atString :: (MonadReader String m, Validate f) => m (f [VError] AtString)
atString = flip liftM ask $ \x ->
  if "@" `isInfixOf` x
    then _Success # AtString x
    else _Failure # [MustContainAt]

-- String must contain an '.' character
periodString :: (MonadReader String m, Validate f) => m (f [VError] PeriodString)
periodString = flip liftM ask $ \x ->
  if "." `isInfixOf` x
    then _Success # PeriodString x
    else _Failure # [MustContainPeriod]

-- String must not be empty
nonEmptyString :: (MonadReader String m, Validate f) => m (f [VError] NonEmptyString)
nonEmptyString = flip liftM ask $ \x ->
  if x /= []
    then _Success # NonEmptyString x
    else _Failure # [MustNotBeEmpty]

(<$$>) :: (Functor f, Functor g) => (a -> b) -> f (g a) -> f (g b)
(<$$>) f = getCompose . (f <$>) . Compose

(<**>) :: (Applicative f, Applicative g) => f (g (a -> b)) -> f (g a) -> f (g b)
x <**> y = getCompose (Compose x <*> Compose y)

(**>) :: (Applicative f, Applicative g) => f (g a) -> f (g b) -> f (g b)
x **> y = getCompose (Compose x *> Compose y)

(<**) :: (Applicative f, Applicative g) => f (g a) -> f (g b) -> f (g a)
x <** y = getCompose (Compose x <* Compose y)

infixl 4 <$$>, <**>, <**, **>

-- ***** Combining smart constructors *****
email :: (Applicative m, MonadReader String m, Validate f, Applicative (f [VError])) => m (f [VError] Email)
--email = Email <$> nonEmptyString <* periodString <* atString
email = Email . unNonEmptyString <$$> nonEmptyString <** periodString <** atString

-- ***** Example usage *****
success :: (Validate f, Applicative (f [VError])) => f [VError] Email
success = email "[email protected]"
-- AccSuccess (Email "[email protected]")

failureAt :: (Validate f, Applicative (f [VError])) => f [VError] Email
failureAt = email "bobgmail.com"
-- AccFailure [MustContainAt]

failurePeriod :: (Validate f, Applicative (f [VError])) => f [VError] Email
failurePeriod = email "bob@gmailcom"
-- AccFailure [MustContainPeriod]

failureAll :: (Validate f, Applicative (f [VError])) => f [VError] Email
failureAll = email ""
-- AccFailure [MustNotBeEmpty,MustContainAt,MustContainPeriod]

-- Helper to force a validation to AccValidation
asAcc :: AccValidation a b -> AccValidation a b
asAcc = id

-- Helper to force a validation to Validation
asVal :: Validation a b -> Validation a b
asVal = id

main :: IO ()
main = do
  putStrLn "Collect all errors"
  putStrLn $ "email \"[email protected]\": " ++ show (asAcc success)
  putStrLn $ "email \"bobgmail.com\":  " ++ show (asAcc failureAt)
  putStrLn $ "email \"bob@gmailcom\":  " ++ show (asAcc failurePeriod)
  putStrLn $ "email \"\":              " ++ show (asAcc failureAll)
  putStrLn "Stop at the first error"
  putStrLn $ "email \"[email protected]\": " ++ show (asVal success)
  putStrLn $ "email \"\":              " ++ show (asVal failureAll)