Steal code from rawSql and stop using it.

Unfortunately we can't use rawSql, since we need explicit control
of the SELECT (i.e. we can't use "??").

esqueleto.cabal

@@ -26,6 +26,6 @@ library
     , monad-supply  == 0.3.*
 
     , monad-logger
-    , resourcet
+    , conduit
   hs-source-dirs: src/
   ghc-options: -Wall

src/Database/Esqueleto/Internal/Sql.hs

@@ -7,19 +7,23 @@ module Database.Esqueleto.Internal.Sql
   ) where
 
 import Control.Applicative (Applicative(..), (<$>))
-import Control.Arrow (first, (&&&))
+import Control.Arrow (first)
 import Control.Monad (ap)
+import Control.Monad.IO.Class (MonadIO)
 import Control.Monad.Logger (MonadLogger)
-import Control.Monad.Trans.Resource (MonadResourceBase)
 import Data.List (intersperse)
 import Data.Monoid (Monoid(..), (<>))
 import Database.Persist.EntityDef
 import Database.Persist.GenericSql
 import Database.Persist.GenericSql.Internal (Connection(escapeName))
+import Database.Persist.GenericSql.Raw (withStmt)
 import Database.Persist.Store
 import qualified Control.Monad.Supply as S
 import qualified Control.Monad.Trans.Reader as R
 import qualified Control.Monad.Trans.Writer as W
+import qualified Data.Conduit as C
+import qualified Data.Conduit.List as CL
+import qualified Data.Text as T
 import qualified Data.Text.Lazy as TL
 import qualified Data.Text.Lazy.Builder as TLB
 
@@ -57,7 +61,7 @@ instance Monoid SideData where
 data FromClause  = From Ident EntityDef
 
 
--- | A complere @WHERE@ clause.
+-- | A complete @WHERE@ clause.
 data WhereClause = Where (SqlExpr (Single Bool))
                  | NoWhere
 
@@ -69,7 +73,7 @@ instance Monoid WhereClause where
 
 
 -- | Identifier used for tables.
-newtype Ident = I  TLB.Builder
+newtype Ident = I TLB.Builder
 
 
 -- | Infinite list of identifiers.
@@ -138,18 +142,44 @@ binop op (ERaw f1) (ERaw f2) = ERaw f
                , vals1 <> vals2 )
 
 
+-- | Execute an Esqueleto's 'SqlQuery' inside @persistent@'s
+-- 'SqlPersist' monad.
+selectSource :: ( SqlSelect a r
+                , C.MonadResource m
+                , MonadLogger m
+                , MonadIO m )
+             => SqlQuery a -> SqlPersist m (C.Source (SqlPersist m) r)
+selectSource query = src
+    where
+      src = do
+        conn <- getConnection
+        return $ run conn C.$= massage
+
+      run conn =
+        uncurry withStmt $
+        first (TL.toStrict . TLB.toLazyText) $
+        toRawSelectSql (fromDBName conn) query
+
+      massage = do
+        mrow <- C.await
+        case process <$> mrow of
+          Just (Right r)  -> C.yield r >> massage
+          Just (Left err) -> fail (T.unpack err)
+          Nothing         -> return ()
+
+      process = sqlSelectProcessRow
+
+
 -- | Execute an Esqueleto's 'SqlQuery' inside @persistent@'s
 -- 'SqlPersist' monad.
 select :: ( SqlSelect a r
-          , RawSql r
+          , C.MonadResource m
           , MonadLogger m
-          , MonadResourceBase m)
+          , MonadIO m )
        => SqlQuery a -> SqlPersist m [r]
 select query = do
-  conn <- getConnection
+  src <- selectSource query
-  uncurry rawSql $
+  src C.$$ CL.consume
-    first (TL.toStrict . TLB.toLazyText) $
-    toRawSelectSql (fromDBName conn) query
 
 
 -- | Get current database 'Connection'.
@@ -165,8 +195,8 @@ toRawSelectSql esc query =
         W.runWriterT $
         unQ query
 
-      (selectText, selectVars) = makeSelect esc ret
+      (_, selectText, selectVars) = sqlSelectCols esc ret
-      (whereText,  whereVars)  = makeWhere  esc whereClauses
+      (   whereText,  whereVars)  = makeWhere esc whereClauses
 
       text = mconcat
              [ "SELECT "
@@ -181,8 +211,10 @@ toRawSelectSql esc query =
 uncommas :: [TLB.Builder] -> TLB.Builder
 uncommas = mconcat . intersperse ", "
 
-uncommas' :: Monoid a => [(TLB.Builder, a)] -> (TLB.Builder, a)
+uncommas' :: Monoid a => [(Int, TLB.Builder, a)] -> (Int, TLB.Builder, a)
-uncommas' = uncommas . map fst &&& mconcat . map snd
+uncommas' xs =
+  let (as, bs, cs) = unzip3 xs
+  in (sum as, uncommas bs, mconcat cs)
 
 
 makeFrom :: Escape -> [FromClause] -> TLB.Builder
@@ -202,47 +234,105 @@ parens b = "(" <> (b <> "(")
 
 -- | Class for mapping results coming from 'SqlQuery' into actual
 -- results.
-class RawSql r => SqlSelect a r | a -> r, r -> a where
+--
-  makeSelect :: Escape -> a -> (TLB.Builder, [PersistValue])
+-- This looks very similar to @RawSql@, and it is!  However,
+-- there are some crucial differences and ultimately they're
+-- different classes.
+class SqlSelect a r | a -> r, r -> a where
+  -- | Creates the variable part of the @SELECT@ query and
+  -- returns the list of 'PersistValue's that will be given to
+  -- 'withStmt'.
+  sqlSelectCols :: Escape -> a -> (Int, TLB.Builder, [PersistValue])
+
+  -- | Transform a row of the result into the data type.
+  sqlSelectProcessRow :: [PersistValue] -> Either T.Text r
+
 
 instance PersistEntity a => SqlSelect (SqlExpr (Entity a)) (Entity a) where
-  makeSelect _ (EEntity _) = ("??", mempty)
+  sqlSelectCols escape expr@(EEntity (I ident)) = ret
+      where
+        process ed = uncommas $
+                     map ((name <>) . escape) $
+                     (entityID ed:) $
+                     map fieldDB $
+                     entityFields ed
+        -- 'name' is the biggest difference between 'RawSql' and
+        -- 'SqlSelect'.  We automatically create names for tables
+        -- (since it's not the user who's writing the FROM
+        -- clause), while 'rawSql' assumes that it's just the
+        -- name of the table (which doesn't allow self-joins, for
+        -- example).
+        name = ident <> "."
+        ret = let ed = entityDef $ getEntityVal expr
+              in (length (entityFields ed) + 1, process ed, mempty)
+        getEntityVal :: SqlExpr (Entity a) -> a
+        getEntityVal = error "Database.Esqueleto.SqlSelect.getEntityVal"
+  sqlSelectProcessRow (idCol:ent) =
+    Entity <$> fromPersistValue idCol
+           <*> fromPersistValues ent
+  sqlSelectProcessRow _ = Left "SqlSelect (Entity a): wrong number of columns."
 
 instance PersistField a => SqlSelect (SqlExpr (Single a)) (Single a) where
-  makeSelect esc (ERaw f) = first parens (f esc)
+  sqlSelectCols esc (ERaw f) = let (b, vals) = f esc
+                               in (1, parens b, vals)
+  sqlSelectProcessRow [pv] = Single <$> fromPersistValue pv
+  sqlSelectProcessRow _    = Left "SqlSelect (Single a): wrong number of columns."
 
 instance ( SqlSelect a ra
          , SqlSelect b rb
          ) => SqlSelect (a, b) (ra, rb) where
-  makeSelect esc (a, b) =
+  sqlSelectCols esc (a, b) =
     uncommas'
-      [ makeSelect esc a
+      [ sqlSelectCols esc a
-      , makeSelect esc b
+      , sqlSelectCols esc b
       ]
+  sqlSelectProcessRow =
+    let x = getType processRow
+        getType :: SqlSelect a r => (z -> Either y (r,x)) -> a
+        getType = undefined
+
+        (colCountFst, _, _) = sqlSelectCols undefined x
+        processRow row =
+            let (rowFst, rowSnd) = splitAt colCountFst row
+            in (,) <$> sqlSelectProcessRow rowFst
+                   <*> sqlSelectProcessRow rowSnd
+
+    in colCountFst `seq` processRow
+       -- Avoids recalculating 'colCountFst'.
 
 instance ( SqlSelect a ra
          , SqlSelect b rb
          , SqlSelect c rc
          ) => SqlSelect (a, b, c) (ra, rb, rc) where
-  makeSelect esc (a, b, c) =
+  sqlSelectCols esc (a, b, c) =
     uncommas'
-      [ makeSelect esc a
+      [ sqlSelectCols esc a
-      , makeSelect esc b
+      , sqlSelectCols esc b
-      , makeSelect esc c
+      , sqlSelectCols esc c
       ]
+  sqlSelectProcessRow = fmap to3 . sqlSelectProcessRow
+
+to3 :: ((a,b),c) -> (a,b,c)
+to3 ((a,b),c) = (a,b,c)
+
 
 instance ( SqlSelect a ra
          , SqlSelect b rb
          , SqlSelect c rc
          , SqlSelect d rd
          ) => SqlSelect (a, b, c, d) (ra, rb, rc, rd) where
-  makeSelect esc (a, b, c, d) =
+  sqlSelectCols esc (a, b, c, d) =
     uncommas'
-      [ makeSelect esc a
+      [ sqlSelectCols esc a
-      , makeSelect esc b
+      , sqlSelectCols esc b
-      , makeSelect esc c
+      , sqlSelectCols esc c
-      , makeSelect esc d
+      , sqlSelectCols esc d
       ]
+  sqlSelectProcessRow = fmap to4 . sqlSelectProcessRow
+
+to4 :: ((a,b),(c,d)) -> (a,b,c,d)
+to4 ((a,b),(c,d)) = (a,b,c,d)
+
 
 instance ( SqlSelect a ra
          , SqlSelect b rb
@@ -250,14 +340,19 @@ instance ( SqlSelect a ra
          , SqlSelect d rd
          , SqlSelect e re
          ) => SqlSelect (a, b, c, d, e) (ra, rb, rc, rd, re) where
-  makeSelect esc (a, b, c, d, e) =
+  sqlSelectCols esc (a, b, c, d, e) =
     uncommas'
-      [ makeSelect esc a
+      [ sqlSelectCols esc a
-      , makeSelect esc b
+      , sqlSelectCols esc b
-      , makeSelect esc c
+      , sqlSelectCols esc c
-      , makeSelect esc d
+      , sqlSelectCols esc d
-      , makeSelect esc e
+      , sqlSelectCols esc e
       ]
+  sqlSelectProcessRow = fmap to5 . sqlSelectProcessRow
+
+to5 :: ((a,b),(c,d),e) -> (a,b,c,d,e)
+to5 ((a,b),(c,d),e) = (a,b,c,d,e)
+
 
 instance ( SqlSelect a ra
          , SqlSelect b rb
@@ -266,15 +361,20 @@ instance ( SqlSelect a ra
          , SqlSelect e re
          , SqlSelect f rf
          ) => SqlSelect (a, b, c, d, e, f) (ra, rb, rc, rd, re, rf) where
-  makeSelect esc (a, b, c, d, e, f) =
+  sqlSelectCols esc (a, b, c, d, e, f) =
     uncommas'
-      [ makeSelect esc a
+      [ sqlSelectCols esc a
-      , makeSelect esc b
+      , sqlSelectCols esc b
-      , makeSelect esc c
+      , sqlSelectCols esc c
-      , makeSelect esc d
+      , sqlSelectCols esc d
-      , makeSelect esc e
+      , sqlSelectCols esc e
-      , makeSelect esc f
+      , sqlSelectCols esc f
       ]
+  sqlSelectProcessRow = fmap to6 . sqlSelectProcessRow
+
+to6 :: ((a,b),(c,d),(e,f)) -> (a,b,c,d,e,f)
+to6 ((a,b),(c,d),(e,f)) = (a,b,c,d,e,f)
+
 
 instance ( SqlSelect a ra
          , SqlSelect b rb
@@ -284,16 +384,21 @@ instance ( SqlSelect a ra
          , SqlSelect f rf
          , SqlSelect g rg
          ) => SqlSelect (a, b, c, d, e, f, g) (ra, rb, rc, rd, re, rf, rg) where
-  makeSelect esc (a, b, c, d, e, f, g) =
+  sqlSelectCols esc (a, b, c, d, e, f, g) =
     uncommas'
-      [ makeSelect esc a
+      [ sqlSelectCols esc a
-      , makeSelect esc b
+      , sqlSelectCols esc b
-      , makeSelect esc c
+      , sqlSelectCols esc c
-      , makeSelect esc d
+      , sqlSelectCols esc d
-      , makeSelect esc e
+      , sqlSelectCols esc e
-      , makeSelect esc f
+      , sqlSelectCols esc f
-      , makeSelect esc g
+      , sqlSelectCols esc g
       ]
+  sqlSelectProcessRow = fmap to7 . sqlSelectProcessRow
+
+to7 :: ((a,b),(c,d),(e,f),g) -> (a,b,c,d,e,f,g)
+to7 ((a,b),(c,d),(e,f),g) = (a,b,c,d,e,f,g)
+
 
 instance ( SqlSelect a ra
          , SqlSelect b rb
@@ -304,14 +409,18 @@ instance ( SqlSelect a ra
          , SqlSelect g rg
          , SqlSelect h rh
          ) => SqlSelect (a, b, c, d, e, f, g, h) (ra, rb, rc, rd, re, rf, rg, rh) where
-  makeSelect esc (a, b, c, d, e, f, g, h) =
+  sqlSelectCols esc (a, b, c, d, e, f, g, h) =
     uncommas'
-      [ makeSelect esc a
+      [ sqlSelectCols esc a
-      , makeSelect esc b
+      , sqlSelectCols esc b
-      , makeSelect esc c
+      , sqlSelectCols esc c
-      , makeSelect esc d
+      , sqlSelectCols esc d
-      , makeSelect esc e
+      , sqlSelectCols esc e
-      , makeSelect esc f
+      , sqlSelectCols esc f
-      , makeSelect esc g
+      , sqlSelectCols esc g
-      , makeSelect esc h
+      , sqlSelectCols esc h
       ]
+  sqlSelectProcessRow = fmap to8 . sqlSelectProcessRow
+
+to8 :: ((a,b),(c,d),(e,f),(g,h)) -> (a,b,c,d,e,f,g,h)
+to8 ((a,b),(c,d),(e,f),(g,h)) = (a,b,c,d,e,f,g,h)