Постоянный: CRUD TypeClass

Я пытаюсь написать класс типов, упрощающий написание бэкенда CRUD с использованием persistent, aeson и scotty.

Вот моя идея:

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, но я не понимаю, как это сделать.


crud persistent haskell yesod
person agrafix    schedule 11.04.2013    source источник

Ответы (1)


arrow_upward
2
arrow_downward

Ограничение означает, что связанный тип серверной части для 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 ()
person GS - Apologise to Monica    schedule 04.01.2014
comment
Спасибо! :-) Я тоже пришел к чему-то подобному, но мне бы очень хотелось, чтобы он работал со всеми постоянными бэкэндами, а не только с SQL. Я знаю, что текущий runDB обеспечивает это, поэтому я думаю, что мне, вероятно, нужно еще больше абстракции. - person agrafix; 05.01.2014
comment
Ограничение исходит из реализации mkInsertRoute по умолчанию. Возможно, вам следует удалить значение по умолчанию из определения класса или абстрагироваться от бита runDB $ SQL.insert? - person GS - Apologise to Monica; 05.01.2014
comment
Я думаю, достаточно абстрагироваться над runDB? - person agrafix; 08.01.2014
comment
Подпись типа для вставки — insert :: (PersistMonadBackend m ~ PersistEntityBackend val, PersistEntity val) => val -> m (Key val), она будет работать с любым бэкендом. - person agrafix; 09.01.2014
comment
Достаточно честно, просто был введен в заблуждение тем, откуда он был импортирован. - person GS - Apologise to Monica; 09.01.2014