改进冗长的Haskell Monadic代码

Question

以下函数是Yesod REST服务器的一部分,通过电子邮件地址在MongoDB数据库中搜索现有用户,并返回Maybe User:

{-# LANGUAGE DeriveGeneric #-}

module Model.User where

import           Database.MongoDB (Action, findOne, select, (=:))
import qualified Database.MongoDB as M
import           GHC.Generics     (Generic)
import           Import

data User = User
  { userEmail     :: Text
  , userFirstName :: Text
  , userLastName  :: Text
  } deriving (Generic, Show)

collection :: Text
collection = "users"

instance FromJSON User
instance ToJSON User

findForEmail :: Text -> Action IO (Maybe User)
findForEmail email = do
  maybeDocument <- findOne (select [ "email" =: email ] collection)
  case maybeDocument of
    Just document -> do
      email' <- M.lookup "email" document
      firstName <- M.lookup "firstName" document
      lastName <- M.lookup "lastName" document
      return $ Just $ User email' firstName lastName
    Nothing       -> return Nothing

涉及两个"嵌套"monad(maybeDocument <-)的部分感觉非常"啰嗦".findOne返回a Maybe Document并lookup返回a Maybe v.

这可以缩短,也许使用申请人？

UPDATE

我把它简化为:

maybeDocument <- findOne (select [ "email" =: email ] collection)
case maybeDocument of
  Just document ->
    return $ User <$> M.lookup "email" document
                  <*> M.lookup "firstName" document
                  <*> M.lookup "lastName" document
  Nothing       -> return Nothing

但它仍然感觉很沉重.有没有办法把maybeDocument <-monad和lookups 结合起来？

Answer 1

case在a上Maybe,Just映射到另一个Maybe并Nothing立即到Nothing,与使用一个monadic绑定相同.(当然你需要保持return出局,这里的行为是错误的monad.)

   maybeDocument <- findOne (select [ "email" =: email ] collection)
   return $ maybeDocument >>= \document ->
             User <$> M.lookup "email" document
                  <*> M.lookup "firstName" document
                  <*> M.lookup "lastName" document

此外,maybeDocument变量有点尴尬,我们可以消除这一点:请注意,因为结果只是return编入Action IOmonad,你根本不需要一个do块:你只是 - Functor覆盖结果!这可以很好地完成无点:

   fmap (>>= \document ->
             User <$> M.lookup "email" document
                  <*> M.lookup "firstName" document
                  <*> M.lookup "lastName" document
        ) $ findOne (select [ "email" =: email ] collection)

如果我们能够保留原始的"评估顺序",你可能会认为这看起来会更好一些.我们可以使用(非标准)反向应用运算符

      findOne (select [ "email" =: email ] collection)  <&>  (>>=
         \document -> User <$> M.lookup "email" document
                           <*> M.lookup "firstName" document
                           <*> M.lookup "lastName" document  )

当然,这使得很难掌握每个操作员正在做什么,但我认为IMO在这种简洁的代码中的总体意图非常明确.