防止Typeclass限制向​​上傳播通過變壓器堆棧

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 'me@blah.com'"() 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