From a01f9c856367d567861d8e59e71c46aecd12521a Mon Sep 17 00:00:00 2001
From: Matt Parsons <parsonsmatt@gmail.com>
Date: Wed, 13 Sep 2017 17:00:31 -0600
Subject: [PATCH] Add projection function

---
 src/Database/Esqueleto/Internal/Language.hs | 15 +++++++++++----
 src/Database/Esqueleto/Internal/Sql.hs      | 16 +++++++++++-----
 2 files changed, 22 insertions(+), 9 deletions(-)

diff --git a/src/Database/Esqueleto/Internal/Language.hs b/src/Database/Esqueleto/Internal/Language.hs
index 724b98f..291d102 100644
--- a/src/Database/Esqueleto/Internal/Language.hs
+++ b/src/Database/Esqueleto/Internal/Language.hs
@@ -54,11 +54,18 @@ import qualified Data.ByteString as B
 import qualified Data.Text as T
 import qualified Data.Text.Lazy as TL
 
-class BackendCompatible sup sub
+class BackendCompatible sup sub where
+  projectBackend :: sub -> sup
+
+instance BackendCompatible SqlBackend SqlBackend where
+  projectBackend = id
+
+instance BackendCompatible SqlBackend SqlReadBackend where
+  projectBackend = unSqlReadBackend
+
+instance BackendCompatible SqlBackend SqlWriteBackend where
+  projectBackend = unSqlWriteBackend
 
-instance BackendCompatible SqlBackend SqlBackend
-instance BackendCompatible SqlBackend SqlReadBackend
-instance BackendCompatible SqlBackend SqlWriteBackend
 
 -- | Finally tagless representation of @esqueleto@'s EDSL.
 class (Functor query, Applicative query, Monad query) =>
diff --git a/src/Database/Esqueleto/Internal/Sql.hs b/src/Database/Esqueleto/Internal/Sql.hs
index 02861ab..0d99f3b 100644
--- a/src/Database/Esqueleto/Internal/Sql.hs
+++ b/src/Database/Esqueleto/Internal/Sql.hs
@@ -786,13 +786,16 @@ veryUnsafeCoerceSqlExprValueList EEmptyList = throw (UnexpectedCaseErr EmptySqlE
 -- @persistent@'s 'SqlPersistT' monad.
 rawSelectSource :: ( SqlSelect a r
                    , MonadIO m1
-                   , MonadIO m2 )
+                   , MonadIO m2
+                   , SqlBackendCanRead backend
+                   , BackendCompatible SqlBackend backend)
                  => Mode
                  -> SqlQuery a
-                 -> SqlReadT m1 (Acquire (C.Source m2 r))
+                 -> R.ReaderT backend m1 (Acquire (C.Source m2 r))
 rawSelectSource mode query =
       do
-        conn <- persistBackend <$> R.ask
+        conn <- projectBackend <$> R.ask
+        let _ = conn :: SqlBackend
         res <- run conn
         return $ (C.$= massage) `fmap` res
     where
@@ -866,8 +869,11 @@ selectSource query = do
 -- function composition that the @p@ inside the query is of type
 -- @SqlExpr (Entity Person)@.
 select :: ( SqlSelect a r
-          , MonadIO m )
-       => SqlQuery a -> SqlReadT m [r]
+          , MonadIO m
+          , SqlBackendCanRead backend
+          , BackendCompatible SqlBackend backend
+          )
+       => SqlQuery a -> R.ReaderT backend m [r]
 select query = do
     res <- rawSelectSource SELECT query
     conn <- R.ask