防止类型类约束通过转换器堆栈向上传播

Question

我有很多数据库(和其他数据源)，我在工作中使用，每一个都略有不同，可能是不同的后端，或者需要在运行时提供略有不同的信息，所以每当我在haskell中编写程序时，我必须处理很多逻辑，与db这个和ConnectInfo那个，传递这个句柄在这里或那里，它最终淹没了我的程序的逻辑，这通常是非常简单的。

所以我决定写一个小库来为我做所有繁重的工作。

我觉得我正在接近我的目标，但我还没有完全实现。在这里，我有两个虚拟数据库，A和B，一个只需要查询，但另一个要求我指定要查询的数据库的名称。

#!/usr/bin/env stack
-- stack --resolver lts-6.22  runghc --package mtl --package mysql-simple
{-# LANGUAGE ExistentialQuantification, LambdaCase, FlexibleInstances, FlexibleContexts, UndecidableInstances, OverloadedStrings #-}
{-# OPTIONS_GHC -Wall #-}
module West.Databases.Types where
import Control.Monad.Trans.Resource
import Control.Monad.Trans
import Control.Monad.State.Strict
import Database.MySQL.Simple as MS
import Database.MySQL.Simple.QueryParams as MS
import Database.MySQL.Simple.QueryResults as MS
newtype DBName = DBName String deriving Eq
data DBState = DBState {
    aDBConn :: Maybe Connection
  , bDBConn :: Maybe (Connection, DBName)
}
class MonadResource m => MonadDB m where
  liftDB :: DBAction a -> m a
runB :: DBName -> BQuery a -> DBAction a
runB dbname (BQuery q p f) = BAction dbname q p f
runA :: AQuery a -> DBAction a
runA (AQuery q p f) = AAction q p f
instance (MonadState DBState m, MonadResource m, MonadIO m) => MonadDB m where
  liftDB (AAction q p f) = f <$> do
    (aDBConn <$> get) >>= case
      Nothing -> do
        newconn <- snd <$> allocate (MS.connect (undefined :: ConnectInfo)) MS.close
        modify (dbs -> dbs { aDBConn = Just newconn })
        liftIO (MS.query newconn q p)
      Just aconn -> liftIO (MS.query aconn q p)
  liftDB (BAction newdbname q p f) = f <$> do
    (bDBConn <$> get) >>= case
      Nothing -> undefined
      Just (bconn, dbname) -> if dbname == newdbname
        then liftIO (MS.query bconn q p)
        else do
          -- MS.query "use newdbname"
          liftIO (MS.query bconn q p)
data DBAction a =
    forall r p. AAction Query p ([r] -> a)
  | forall r p. BAction DBName Query p ([r] -> a)
instance Functor DBAction where
  fmap f (AAction q p fr) = AAction  q p (f . fr)
  fmap f (BAction dbname q p fr) = BAction dbname q p (f . fr)
-- TODO
instance Applicative DBAction
instance Monad DBAction
data BQuery a = forall r p. BQuery Query p ([r] -> a)
data AQuery a = forall r p. AQuery Query p ([r] -> a)

这允许我写这样的代码

data UID
data Password
me :: AQuery (UID, DBName)
me = AQuery "select uid,customerdb from users where user_name rlike '[e-mail]'" () undefined
friends :: UID -> BQuery Int
friends uid = BQuery "select count(*) from friends where uid = ?" uid undefined
userCount :: AQuery Int
userCount = AQuery "select count(*) from users" () toCount
  where
    toCount ((Only i):_) = i
    toCount _ = error "userCount should not occur"
userAuth :: UID -> Password -> AQuery Bool
userAuth uid pass = AQuery "select count(*) from users where uid = ? and password = ?" (uid, pass)
  (c -> head c > (0 :: Int))

，还可以将不同数据库的操作组合到可以运行liftDB的过程中。这将在主数据库中查找用户，然后查询该数据库以获取有关该用户的更深入信息。

myFriends :: DBAction Int
myFriends = do
  (uid, dbname) <- runA me
  runB dbname (friends uid)

问题是msyql/postgresql-simple库都具有非常相似的query函数，具有以下类型

query :: (ToRow q, FromRow r) => Connection -> Query -> q -> IO [r]
query :: (QueryParams q, QueryResults r) => Connection -> Query -> q -> IO [r]

导致ToRow/QueryParams/FromRow/QueryResults传播到MonadDB类，这可能不应该发生，但我不知道如何防止它。我觉得DBAction应该以某种方式包含运行查询和更新某些状态所需的逻辑…

Answer 1

经过一段时间的工作，我找到了我一直在寻找的解决方案。

data DBAction a =
    forall p r. (QueryParams p, QueryResults r) => AAction Query p ([r] -> a)
  | forall p r. (QueryParams p, QueryResults r) => BAction DBName Query p ([r] -> a)
  -- forall p r. (FromRow r, ToRow r) => .... etc.
data AQuery a = forall r p. (QueryParams p, QueryResults r) => AQuery Query p ([r] -> a)
data BQuery a = forall r p. (QueryParams p, QueryResults r) => BQuery Query p ([r] -> a)

然后改变我的查询，使它们给出具体的类型，以消除查询时的歧义。

friends :: UID -> BQuery Int
friends uid = BQuery "select count(*) from friends where uid = ?" (undefined uid :: (Only Int)) toCount
  where
    toCount ((Only i):_) = i
    toCount _ = 0