Is it necessary to write Haskell generics in a recursive fashion?

Question

Most examples for Haskell generics do small bits of computation recursively around the :+: and :*: types/constructors. I seem to be solving a problem where this may not work out.

I'm trying to write a generic validation function that takes any two records having the same shape and validates each field in recordA against a validation function defined in recordB to return an error record of the same shape OR recordA itself.

Example:

-- Some type synonyms for better readability
type Name = Text
type Age = Int
type Email = Text
type GeneralError = Text
type FieldError = Text

-- a polymorphic record to help preserve the shape of various records
data User n a e = User {name :: n, age :: a, email :: e}

-- the incoming value which has been parsed into the correct type
-- but still needs various values to be validated, eg length, format, etc
type UserInput = User Name Age Email

-- specifies the exact errors for each field
type UserError = User [FieldError] [FieldError] [FieldError]

-- specifies how to validate each field. the validator is being passed
-- the complete record along with the specific field to allow
-- validations that depends on the value of another field
type UserValidator = User
                     (UserInput -> Name -> Either ([GeneralError], [FieldError]) Name)
                     (UserInput -> Age -> Either ([GeneralError], [FieldError]) Age)
                     (UserInput -> Email -> Either ([GeneralError], [FieldError]) Email)

let (validationResult :: Either ([GeneralError], UserError) UserInput)
  = genericValidation (i :: UserInput) (v :: UserValidator)

Now, the reason why doing this recursively around :*: might not work is, that one needs to look at the result of every validation function and then decide if the return value should be a Left ([GeneralError], UserError) or a Right UserInput. We cannot evaluate to a Left value on the first validation function that fails.

Is there any way to write this genericValidation function using Haskell generics?

Answer 1

Now, the reason why doing this recursively around :*: might not work is, that one needs to look at the result of every validation function and then decide if the return value should be a Left ([GeneralError], UserError) or a Right UserInput. We cannot evaluate to a Left value on the first validation function that fails.

The standard Applicative behaviour for Either is not the only reasonable behaviour for that type! As you said, when you're, eg, validating a form, you want to return a collection of all the errors that occurred, not just the first one. So here's a type that's structurally the same as Either but has a different Applicative instance.

newtype Validation e a = Validation (Either e a) deriving Functor

instance Semigroup e => Applicative (Validation e) where
    pure = Validation . pure
    Validation (Right f) <*> Validation (Right x) = Validation (Right $ f x)
    Validation (Left e1) <*> Validation (Left e2) = Validation (Left $ e1 <> e2)
    Validation (Left e) <*> _ = Validation (Left e)
    _ <*> Validation (Left e) = Validation (Left e)

When both computations failed, the composed computation also fails, returning the two errors composed using their Semigroup instance - both the errors, for some suitable notion of both. If both computations succeed, or only one of them fails, then Validation behaves like Either. So it's kind of like a Frankensteinian mishmash of the Either and Writer applicatives.

This instance does satisfy the Applicative laws, but I'll leave the proof to you. Oh, and Validation can't be made into a lawful Monad.

---

Forgive me for taking the liberty of rearranging your types a bit. I'm using a common trick for reusing the structure of a record at a variety of different types: parameterise the record by a type constructor. You recover the original record by applying the template to the Identity functor.

data UserTemplate f = UserTemplate {
    name :: f Name,
    age :: f Age,
    email :: f Email
}
type User = UserTemplate Identity

A useful newtype: a Validator is a function which takes an a and returns either the a or a monoidal summary of the errors.

newtype Validator e a = Validator { runValidator :: a -> Validation e a }

A useful class: HTraversable is like Traversable but for functors from the category of type constructors to Hask. (More on this in a previous question of mine.)

class HFunctor t where
    hmap :: (forall x. f x -> g x) -> t f -> t g
class HFunctor t => HTraversable t where
    htraverse :: Applicative a => (forall x. f x -> Compose a g x) -> t f -> a (t g)
    htraverse f = hsequence . hmap f
    hsequence :: Applicative a => t (Compose a g) -> a (t g)
    hsequence = htraverse id

Why's HTraversable relevant? TraversableClassic™ allows you to sequence Applicative effects like Validation over homogeneous containers like lists. But a record is rather more like a heterogeneous container: a record "contains" a bunch of fields, but each field has its own type. HTraversable is precisely the class for when you need to sequence Applicative actions over polymorphic containers.

Another useful class generalises zipWith to these heterogeneous containers.

class HZip t where
    hzip :: (forall x. f x -> g x -> h x) -> t f -> t g -> t h

Records constructed in the fashion of UserTemplate are traversable and zippable. (In fact they're typically HRepresentable - an analogous higher-order notion of Representable - which is a very useful property, though I won't dwell on it here.)

instance HFunctor UserTemplate where
    hmap f (UserTemplate n a e) = UserTemplate (f n) (f a) (f e)

instance HTraversable UserTemplate where
    htraverse f (UserTemplate n a e) = UserTemplate <$>
        getCompose (f n) <*>
        getCompose (f a) <*>
        getCompose (f e)

instance HZip UserTemplate where
    hzip f (UserTemplate n1 a1 e1) (UserTemplate n2 a2 e2) = UserTemplate (f n1 n2) (f a1 a2) (f e1 e2)

Hopefully it should be quite easy to see what a Generic or Template Haskell implementation of HTraversable and HZip for an arbitrary record fitting this pattern would do.

So, the plan is: write Validators for each field and then hzip these Validators along the object you want to validate. Then you can htraverse the result to get a Validation containing the validated object. This pattern works for field-by-field validation, per your question. If you need to look at multiple fields to validate your record, you can't use hzip (but of course you also can't use Generic).

type Validatable t = (HZip t, HTraversable t)
validate :: (Semigroup e, Validatable t) => t (Validator e) -> Validator e (t Identity)
validate t = Validator $ htraverse (Compose . fmap Identity) . hzip val t
    where val v = runValidator v . runIdentity

A particular validator for a type such as User basically involves picking a monoidal error and returning a record of validation functions. Here I'm defining a Monoid for UserError which lifts a monoidal e point-wise through each field of the record.

type UserError e = UserTemplate (Const e)

instance Semigroup e => Semigroup (UserError e) where
   x <> y = hzip (<>) x y

Now you can just define a record of validator functions.

type UserValidator = Validator ([GeneralError], UserError [FieldError])

validateEmail :: UserInput -> UserValidator Email
validateEmail i = Validator v
    where v e
            | '@' `elem` toString e = pure e
            | otherwise = Validation $ Left ([], UserTemplate [] [] [FieldError "missing @"])

validateName :: UserInput -> UserValidator Name
validateName = ...
validateAge :: UserInput -> UserValidator Age
validateAge = ...

userValidator :: UserInput -> UserValidator User
userValidator input = validate $ UserTemplate {
    name = validateName input,
    age = validateAge input,
    email = validateEmail input
}

You can make it easier to compose smaller validators - so that each validator doesn't need to know about the whole error structure - using lenses.

Answer 2

This answer tries to comply with the requirement that field-specific errors should be stored in an appropriate slot. I don't tackle "general errors" because they are simpler to implement and this answer is sufficiently complicated as it is.

Instead of using polymorphic records, we will use regular records, augmented with the generics-sop library. This library lets you define and work with generic representations of records, in which each record field is wrapped in some type constructor. The generic representations are basically n-ary products parameterized by a type-level list of field types. Notice that the fields don't have names; if we want to manipulate the n-ary products directly, we need to work positionally.

import Data.Bifunctor (bimap)
import qualified GHC.Generics as GHC
import Generics.SOP
import Control.Applicative.Lift (Errors,runErrors,failure)

data User = User { name :: Name, age :: Age, email :: Email } deriving (Show,GHC.Generic)

instance Generic User -- this generic is from generics-sop

---

A field validation type that depends on Errors from transformers. Notice that it also receives the whole record r:

newtype Validator r a = 
    Validator { runValidator :: r -> a -> Errors [FieldError] a } 

Usher wraps a function that injects FieldErrors in the correct slot of an N-ary error record:

newtype Usher res xs a = Usher { getUsher :: res -> NP (K res) xs }

ushers returns an n-ary product with the appropriate Usher injectors for each field. Notice the Monoid constraint; without it we wouldn't be able to inject empty values in other fields.

ushers :: forall r xs res. (IsProductType r xs, Monoid res)
       => Proxy r -> NP (Usher res xs) xs
ushers _ =
    let expand (Fn injection) =
            Usher $ \res -> hexpand (K mempty) (unK (injection (K res)))
    in hliftA expand (injections @xs @(K res))

Another helper function not provided by generics-sop:

-- combine the individual fields of a list of uniform n-ary-products 
fold_NP :: forall w xs . (Monoid w, SListI xs) => [NP (K w) xs] -> NP (K w) xs
fold_NP = Prelude.foldr (hliftA2 (mapKKK mappend)) (hpure (K mempty))

---

The actual validation function. Notice that the list of validators is provided as an n-ary product (derived from the record r):

validate :: forall r xs . IsProductType r xs
         => NP (Validator r) xs -> r -> Either (NP (K [FieldError]) xs) r
validate validators r =
    let validators' = validators    :: NP (Validator r) xs
        rs = hpure (K r)            :: NP (K r) xs -- a copy of the record in each slot
        np = unZ (unSOP (from r))   :: NP I xs -- generic representation of the record
        validated                   :: NP (Errors [FieldError])   xs
        validated = hliftA3 (\(Validator v) (K rec) (I a) -> v rec a) validators' rs np

        ushers' = ushers (Proxy @r) :: NP (Usher [FieldError] xs) xs -- error injectors
        injected                    :: NP (Errors [NP (K [FieldError]) xs]) xs
        injected = hliftA2 (\(Usher usher) errors ->
                                case runErrors errors of
                                    Right a' -> pure a'
                                    Left es -> failure [usher es])
                           ushers'
                           validated
    in bimap fold_NP (to . SOP . Z) . runErrors . hsequence $ injected

Finally, an example:

main :: IO ()
main = do
   let valfail msg = Validator (\_ _ -> failure [msg])
       validators = valfail "err1" :* valfail "err2" :* valfail "err3" :* Nil 
   print $ validate validators (User "Foo" 40 "boo@bar")
   -- returns Left (K ["err1"] :* (K ["err2"] :* (K ["err3"] :* Nil)))