持久性: 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
    ...

当为某些类型的PersistEntity定义Foo实例时，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 ()