持久性:CRUD TypeClass

Question

我想写简化了使用写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 ()