validation-example.hs

import Data.Semigroup
import Data.Functor
import Control.Applicative

data Validation err a = Failure err | Success a
  deriving Show

instance Functor (Validation err) where
  fmap f (Success a) = Success (f a)
  fmap _ (Failure e) = Failure e

instance Semigroup err => Applicative (Validation err) where
  pure = Success

  Success f <*> Success a  = Success (f a)
  Success _ <*> Failure e  = Failure e
  Failure e <*> Success _  = Failure e
  Failure e <*> Failure e' = Failure (e <> e')

instance Foldable (Validation err) where
  foldr f x (Success a) = f a x
  foldr _ x (Failure _) = x

instance Traversable (Validation err) where
  traverse f (Success a) = Success <$> f a
  traverse _ (Failure e) = pure (Failure e)

data Form = Form {
    email    :: String
  , password :: String
} deriving Show

data Error = 
    EmptyField
  | NotMinLength
  deriving Show

newtype Email = Email String
  deriving Show

newtype Password = Password String
  deriving Show

data ValidatedForm = ValidatedForm Email Password
  deriving Show

type FormValidation = Validation [Error]

notEmpty :: String -> FormValidation String
notEmpty ""  = Failure [EmptyField]
notEmpty str = Success str

minLength :: String -> Int -> FormValidation String
minLength str n
  | length str >= n = Success str
  | otherwise       = Failure [NotMinLength]

minPasswordLength :: Int
minPasswordLength = 8

validateEmail :: String -> FormValidation Email
validateEmail input =
  notEmpty input $>
  Email input

validatePassword :: String -> FormValidation Password
validatePassword input =
  notEmpty input *>
  minLength input minPasswordLength $>
  Password input

validateForm :: Form -> FormValidation ValidatedForm
validateForm (Form email password) =
  ValidatedForm <$>
  validateEmail email <*>
  validatePassword password
  
mkForm :: String -> String -> FormValidation ValidatedForm
mkForm email password = validateForm $ Form email password