是否有必要以递归方式编写 Haskell 泛型？

Question

Haskell 泛型的大多数示例围绕 :+: 和 :*: 类型/构造函数递归地进行少量计算。我似乎正在解决一个可能无法解决的问题。

我正在尝试编写一个 generic 验证函数，它采用具有相同形状的任意两条记录，并根据 recordB 中定义的验证函数验证 recordA 中的每个字段，以返回 same 形状 OR recordA 本身。

例子：

-- 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)

现在，围绕:*: 递归执行此操作可能不起作用的原因是，需要查看每个 验证函数的结果，然后决定返回值是否应该是@ 987654325@ 或Right UserInput。我们无法在第一个失败的验证函数上评估 Left 值。

有什么方法可以使用 Haskell 泛型编写这个 genericValidation 函数吗？

Answer 1

现在，围绕:*: 递归执行此操作可能不起作用的原因是，需要查看每个验证函数的结果，然后决定返回值应该是Left ([GeneralError], UserError) 还是Right UserInput .我们无法在第一个失败的验证函数上评估 Left 值。

Either 的标准 Applicative 行为并不是该类型唯一合理的行为！正如您所说，当您验证表单时，您希望返回发生的所有错误的集合，而不仅仅是第一个错误。所以这里有一个与Either 结构相同但有不同Applicative 实例的类型。

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)

当两个计算都失败时，组合计算也会失败，返回使用它们的Semigroup 实例组合的两个错误 - 两个错误，对于 both 的一些合适的概念。如果两个计算都成功，或者只有一个失败，那么Validation 的行为类似于Either。所以它有点像 Either 和 Writer 应用程序的科学怪人混搭。

这个实例确实满足Applicative 法律，但我会把证据留给你。哦，还有Validation 不能变成合法的Monad。

---

请原谅我冒昧地重新排列了你的类型。我正在使用一种常见的技巧来重用各种不同类型的记录结构：通过类型构造函数参数化记录。您可以通过将模板应用于Identity 函子来恢复原始记录。

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

一个有用的新类型：Validator 是一个函数，它接受 a 并返回 a 或错误的单面体摘要。

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

一个有用的类：HTraversable 类似于Traversable，但对于从类型构造函数到 Hask 的函子。 （更多信息请参见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

为什么HTraversable 相关？ TraversableClassic™ 允许您将 Applicative 效果（如 Validation）排列在 同类 容器（如列表）上。但是一条记录更像是一个异构容器：一条记录​​“包含”了一堆字段，但每个字段都有自己的类型。 HTraversable 正是您需要在多态容器上对 Applicative 操作进行排序时使用的类。

另一个有用的类将zipWith 推广到这些异构容器。

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

以UserTemplate 的方式构造的记录是可遍历和可压缩的。 （事实上​​，它们通常是 HRepresentable - Representable 的类似高阶概念 - 这是一个非常有用的属性，尽管我不会在这里详述。）

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)

希望很容易看出Generic 或HTraversable 和HZip 的模板Haskell 实现对于适合此模式的任意记录会做什么。

因此，计划是：为每个字段写入Validators，然后在要验证的对象上写入hzip 这些Validators。然后你可以htraverse 得到一个包含验证对象的Validation 的结果。根据您的问题，此模式适用于逐字段验证。如果你需要查看多个字段来验证你的记录，你不能使用hzip（当然你也不能使用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

诸如User 之类的类型的特定验证器基本上涉及选择一个幺半群错误并返回验证函数的记录。在这里，我为UserError 定义了一个Monoid，它通过记录的每个字段逐点提升一个单形e。

type UserError e = UserTemplate (Const e)

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

现在您可以定义验证器函数的记录。

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
}

您可以更轻松地组合更小的验证器 - 这样每个验证器就不需要了解整个错误结构 - 使用镜头。

Answer 2

此答案试图遵守字段特定错误应存储在适当插槽中的要求。我不解决“一般错误”，因为它们更容易实现，而且这个答案已经足够复杂了。

我们将使用常规记录，而不是使用多态记录，并通过generics-sop 库进行扩充。该库允许您定义和使用记录的通用表示，其中每个记录字段都包装在某种类型的构造函数中。通用表示基本上是n-ary products parameterized by a type-level list of field types。请注意，这些字段没有名称；如果我们想直接操作 n 元产品，我们需要在位置上工作。

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

---

依赖于来自transformers 的Errors 的字段验证类型。请注意，它还接收整个记录r：

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

Usher 包装了一个函数，该函数将FieldErrors 注入 N 元错误记录的正确槽中：

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

ushers 返回一个 n 元乘积，每个字段都有适当的 Usher 注入器。注意Monoid 约束；没有它，我们将无法在其他字段中注入空值。

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))

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))

---

实际的验证函数。请注意，验证器列表以 n 元乘积的形式提供（源自记录 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

最后，举个例子：

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)))