持久性：CRUD TypeClass

Question

我正在尝试编写一个类型类来简化使用 persistent、aeson 和 scotty

编写 CRUD 后端

这是我的想法：

runDB x = liftIO $ do info <- mysqlInfo
                      runResourceT $ SQL.withMySQLConn info $ SQL.runSqlConn x

class (J.FromJSON a, J.ToJSON a, SQL.PersistEntity a) => CRUD a where
    getBasePath :: a -> String
    getCrudName :: a -> String

    getFromBody :: a -> ActionM a
    getFromBody _ = do body <- jsonData
                       return body

    mkInsertRoute :: a -> ScottyM ()
    mkInsertRoute el =
        do post (fromString ((getBasePath el) ++ "/" ++ (getCrudName el))) $ do
                body <- getFromBody el
                runDB $ SQL.insert body
                json $ J.Bool True

    mkUpdateRoute :: a -> ScottyM ()
    mkDeleteRoute :: a -> ScottyM ()
    mkGetRoute :: a -> ScottyM ()
    mkGetAllRoute :: a -> ScottyM ()

这不能编译，我得到这个错误：

Could not deduce (SQL.PersistEntityBackend a
                  ~ Database.Persist.GenericSql.Raw.SqlBackend)
from the context (CRUD a)
  bound by the class declaration for `CRUD'
  at WebIf/CRUD.hs:(18,1)-(36,36)
Expected type: SQL.PersistEntityBackend a
  Actual type: SQL.PersistMonadBackend
                 (SQL.SqlPersist (Control.Monad.Trans.Resource.ResourceT IO))
In the second argument of `($)', namely `SQL.insert body'
In a stmt of a 'do' block: runDB $ SQL.insert body
In the second argument of `($)', namely
  `do { body <- getFromBody el;
        runDB $ SQL.insert body;
        json $ J.Bool True }'

似乎我必须添加另一个类型约束，例如PersistMonadBackend m ~ PersistEntityBackend a，但我不知道如何。

Answer 1

约束意味着PersistEntity 实例的关联后端类型必须是SqlBackend，因此当用户实现PersistEntity 类作为实现CRUD 类的一部分时，他们需要指定该类型。

从您的角度来看，您只需要启用 TypeFamilies 扩展并将该约束添加到您的类定义中：

class ( J.FromJSON a, J.ToJSON a, SQL.PersistEntity a
      , SQL.PersistEntityBackend a ~ SQL.SqlBackend
      ) => CRUD a where
    ...

当为某些类型Foo 定义PersistEntity 的实例时，CRUD 的用户需要将PersistEntityBackend 类型定义为SqlBackend：

instance PersistEntity Foo where
    type PersistEntityBackend Foo = SqlBackend

这是我通过 GHC 类型检查器的完整代码副本：

{-# LANGUAGE TypeFamilies #-}

import Control.Monad.Logger
import Control.Monad.Trans
import qualified Data.Aeson as J
import Data.Conduit
import Data.String ( fromString )
import qualified Database.Persist.Sql as SQL
import Web.Scotty

-- incomplete definition, not sure why this instance is now needed
-- but it's not related to your problem
instance MonadLogger IO

-- I can't build persistent-mysql on Windows so I replaced it with a stub
runDB x = liftIO $ runResourceT $ SQL.withSqlConn undefined $ SQL.runSqlConn x

class ( J.FromJSON a, J.ToJSON a, SQL.PersistEntity a
      , SQL.PersistEntityBackend a ~ SQL.SqlBackend
      ) => CRUD a where

    getBasePath :: a -> String
    getCrudName :: a -> String

    getFromBody :: a -> ActionM a
    getFromBody _ = do body <- jsonData
                       return body

    mkInsertRoute :: a -> ScottyM ()
    mkInsertRoute el =
        do post (fromString ((getBasePath el) ++ "/" ++ (getCrudName el))) $ do
                body <- getFromBody el
                runDB $ SQL.insert body
                json $ J.Bool True

    mkUpdateRoute :: a -> ScottyM ()
    mkDeleteRoute :: a -> ScottyM ()
    mkGetRoute :: a -> ScottyM ()
    mkGetAllRoute :: a -> ScottyM ()