Typeclass制約がトランススタックを介して上向きに伝播しないようにする

Question

私は職場で使用する多くのデータベース（および他のデータソース）を持っていますが、それぞれが少し異なります。実行時には、いつでも私はhaskellでプログラムを書くたびに、多くのロジックを悩まさなければなりません。これとConnectInfoは、このハンドルをここやそこに渡して、一般的には非常に簡単な私のプログラムのロジックを騒がせてしまいます。

私は少しだけ図書館を書くことにしました。

私は私の目標に近づいているように感じますが、私はかなりありません。これには2つのふりがなのデータベースAとBがありますが、1つはクエリが必要ですが、もう1つは照会するデータベースの名前を指定する必要があります。

#!/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ライブラリの両方がおそらく発生しないはずMonadDBクラス、にまで伝播するToRow/QueryParams/FromRow/QueryResultsが発生し、次のタイプ

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

と非常によく似たqueryの機能を持っているということですしかし、私はそれを防ぐ方法を理解することはできません。私は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