使用EitherT累积错误

Question

我有一个Web API的小型小样本应用程序,它采用了一个巨大的JSON文档,并且应该分解它并报告每个部分的错误消息.

下面的代码是使用EitherT(和错误包)的一个工作示例.但是,问题是EitherT在遇到的第一个Left上打破了计算,只返回它看到的第一个"错误".我想要的是一个错误消息列表,所有可能产生的消息.例如,如果第一行runEitherT失败,那么就没有什么可以做的了.但是如果第二行失败,那么我们仍然可以尝试运行后续行,因为它们对第二行没有数据依赖性.因此,理论上我们可以一次性生成更多(不一定是所有)错误消息.

是否可以懒惰地运行所有计算并返回我们可以找到的所有错误消息？

{-# LANGUAGE OverloadedStrings #-}

module Main where

import Data.ByteString.Lazy.Char8 (pack)
import Web.Scotty as S
import Network.Wai.Middleware.RequestLogger
import Data.Aeson
import Data.Aeson.Types
import Control.Lens hiding ((.=), (??))
import Data.Aeson.Lens
import qualified Data.Text as T
import Control.Error
import Control.Applicative
import qualified Data.HashMap.Strict as H
import Network.HTTP.Types

data TypeOne = TypeOne T.Text TypeTwo TypeThree
  deriving (Show)

data TypeTwo = TypeTwo Double
  deriving (Show)

data TypeThree = TypeThree Double
  deriving (Show)

main :: IO ()
main = scotty 3000 $ do
  middleware logStdoutDev

  post "/pdor" $ do
    api_key <- param "api_key"
    input   <- param "input"

    typeOne <- runEitherT $ do
      result       <- (decode (pack input) :: Maybe Value) ?? "Could not parse. Input JSON document is malformed"
      typeTwoObj   <- (result ^? key "typeTwo")            ?? "Could not find key typeTwo in JSON document."
      typeThreeObj <- (result ^? key "typeThree")          ?? "Could not find key typeThree in JSON document."
      name         <- (result ^? key "name" . _String)     ?? "Could not find key name in JSON document."
      typeTwo      <- hoistEither $ prependLeft "Error when parsing TypeTwo: " $ parseEither jsonTypeTwo typeTwoObj
      typeThree    <- hoistEither $ prependLeft "Error when parsing TypeThree: " $ parseEither jsonTypeThree typeThreeObj

      return $ TypeOne name typeTwo typeThree

    case typeOne of
      Left errorMsg -> do
        _ <- status badRequest400
        S.json $ object ["error" .= errorMsg]
      Right _ ->
        -- do something with the parsed Haskell type
        S.json $ object ["api_key" .= (api_key :: String), "message" .= ("success" :: String)]

prependLeft :: String -> Either String a -> Either String a
prependLeft msg (Left s) = Left (msg ++ s)
prependLeft _ x = x

jsonTypeTwo :: Value -> Parser TypeTwo
jsonTypeTwo (Object v) = TypeTwo <$> v .: "val"
jsonTypeTwo _ = fail $ "no data present for TypeTwo"

jsonTypeThree :: Value -> Parser TypeThree
jsonTypeThree (Object v) = TypeThree <$> v .: "val"
jsonTypeThree _ = fail $ "no data present for TypeThree"

如果有人有一些建议,也可以接受重构建议.

Answer 1

正如我在评论中提到的,您至少有两种累积错误的方法.下面我详细说明这些.我们需要这些进口:

import Control.Applicative
import Data.Monoid
import Data.These

TheseT 单子变压器

免责声明: 在包中TheseT被称为.ChronicleTthese

看一下These数据类型的定义:

data These a b = This a | That b | These a b

这里This和That对应于Left和Right的Either数据类型.These数据构造函数是实现累积功能的原因Monad:它包含结果(类型b)和先前错误的集合(类型集合a).

利用已有的These数据类型定义,我们可以轻松创建类似ErrorTmonad变换器:

newtype TheseT e m a = TheseT {
  runTheseT :: m (These e a)
}

TheseT是以Monad下列方式的实例:

instance Functor m => Functor (TheseT e m) where
  fmap f (TheseT m) = TheseT (fmap (fmap f) m)

instance (Monoid e, Applicative m) => Applicative (TheseT e m) where
  pure x = TheseT (pure (pure x))
  TheseT f <*> TheseT x = TheseT (liftA2 (<*>) f x)

instance (Monoid e, Monad m) => Monad (TheseT e m) where
  return x = TheseT (return (return x))
  m >>= f = TheseT $ do
    t <- runTheseT m
    case t of
      This  e   -> return (This e)
      That    x -> runTheseT (f x)
      These _ x -> do
        t' <- runTheseT (f x)
        return (t >> t')  -- this is where errors get concatenated

Applicative 积累 ErrorT

免责声明:由于您已经在m (Either e a)newtype包装器中工作,因此这种方法更容易适应,但它仅适用于Applicative设置.

如果实际代码仅使用Applicative接口,我们可以通过ErrorT更改其Applicative实例来逃避.

让我们从一个非变压器版本开始:

data Accum e a = ALeft e | ARight a

instance Functor (Accum e) where
  fmap f (ARight x) = ARight (f x)
  fmap _ (ALeft e)  = ALeft e

instance Monoid e => Applicative (Accum e) where
  pure = ARight
  ARight f <*> ARight x = ARight (f x)
  ALeft e  <*> ALeft e' = ALeft (e <> e')
  ALeft e  <*> _        = ALeft e
  _        <*> ALeft e  = ALeft e

请注意,在定义时,<*>我们知道双方是否都是ALefts,因此可以执行<>.如果我们尝试定义相应的Monad实例,我们会失败:

instance Monoid e => Monad (Accum e) where
  return = ARight
  ALeft e >>= f = -- we can't apply f

所以Monad我们可能拥有的唯一例子是Either.但后来ap不一样<*>:

Left a <*>  Left b  ?  Left (a <> b)
Left a `ap` Left b  ?  Left a

所以我们只能Accum用作Applicative.

现在我们可以Applicative基于以下定义变换器Accum:

newtype AccErrorT e m a = AccErrorT {
  runAccErrorT :: m (Accum e a)
}

instance (Functor m) => Functor (AccErrorT e m) where
  fmap f (AccErrorT m) = AccErrorT (fmap (fmap f) m)

instance (Monoid e, Applicative m) => Applicative (AccErrorT e m) where
  pure x = AccErrorT (pure (pure x))
  AccErrorT f <*> AccErrorT x = AccErrorT (liftA2 (<*>) f x)

请注意,这AccErrorT e m基本上是Compose m (Accum e).

编辑:

AccErrorAccValidation在validation包中被称为.