HaskellDBのquery関数がstrictなので無理やりlazyにしてみるpatch。HDBC専用。HSQLはどうするのがよいのやら。

haskelldb_hdbc_lazy_query.patch

--- haskelldb-2.2.2/src/Database/HaskellDB/Database.hs  2012-10-26 02:19:38.000000000 +0900
+++ haskelldb-2.2.2/src/Database/HaskellDB/Database.hs	2013-01-17 09:21:06.501451400 +0900
@@ -24,7 +24,7 @@
                 (!.)
 		-- * Type declarations
 		, Database(..)
-		, GetRec(..), GetInstances(..)
+		, GetRec(..), GetInstances(..), GetInstancesIO
                 , GetValue(..)
 		-- * Function declarations
 		, query
@@ -90,34 +90,36 @@
 --   when getting query results.
 --
 --   All these functions should return 'Nothing' if the value is NULL.
-data GetInstances s = 
+data GetInstances m s = 
     GetInstances {
 		 -- | Get a 'String' value.
-		 getString       :: s -> String -> IO (Maybe String)
+		 getString       :: s -> String -> m (Maybe String)
 		 -- | Get an 'Int' value.
-	       , getInt          :: s -> String -> IO (Maybe Int)
+	       , getInt          :: s -> String -> m (Maybe Int)
 		 -- | Get an 'Integer' value.
-	       , getInteger      :: s -> String -> IO (Maybe Integer)
+	       , getInteger      :: s -> String -> m (Maybe Integer)
 		 -- | Get a 'Double' value. 
-	       , getDouble       :: s -> String -> IO (Maybe Double)
+	       , getDouble       :: s -> String -> m (Maybe Double)
 		 -- | Get a 'Bool' value.
-	       , getBool :: s -> String -> IO (Maybe Bool)
+	       , getBool :: s -> String -> m (Maybe Bool)
 		 -- | Get a 'CalendarTime' value.
-	       , getCalendarTime :: s -> String -> IO (Maybe CalendarTime)
+	       , getCalendarTime :: s -> String -> m (Maybe CalendarTime)
 		 -- | Get a 'LocalTime' value.
-	       , getLocalTime :: s -> String -> IO (Maybe LocalTime)
+	       , getLocalTime :: s -> String -> m (Maybe LocalTime)
 	       }
 
+type GetInstancesIO s = GetInstances IO s
 
 class GetRec er vr | er -> vr, vr -> er where
     -- | Create a result record.
-    getRec :: GetInstances s  -- ^ Driver functions for getting values
+    getRec :: Monad m
+           => GetInstances m s -- ^ Driver functions for getting values
 			      --   of different types.
 	   -> Rel er -- ^ Phantom argument to the the return type right
 	   -> Scheme       -- ^ Fields to get.
 	   -> s            -- ^ Driver-specific result data 
 	                   --   (for example a Statement object)
-           -> IO (Record vr)        -- ^ Result record.
+           -> m (Record vr)        -- ^ Result record.
 
 instance GetRec RecNil RecNil where
     -- NOTE: we accept extra fields, since the hacks in Optimize could add fields that we don't want
@@ -136,7 +138,7 @@
 recTailType _ = undefined
 
 class GetValue a where
-    getValue :: GetInstances s -> s -> String -> IO a
+    getValue :: Monad m => GetInstances m s -> s -> String -> m a
 
 -- these are silly, there's probably a cleaner way to do this,
 -- but instance GetValue (Maybe a) => GetValue a doesn't work
@@ -161,7 +163,7 @@
     getValue fs s f = liftM (liftM trunc) (getValue fs s f)
 
 -- | Get a non-NULL value. Fails if the value is NULL.
-getNonNull :: GetValue (Maybe a) => GetInstances s -> s -> String -> IO a
+getNonNull :: (Monad m, GetValue (Maybe a)) => GetInstances m s -> s -> String -> m a
 getNonNull fs s f = 
 	do
 	m <- getValue fs s f
--- haskelldb-hdbc-2.2.2/Database/HaskellDB/HDBC.hs	2012-10-26 01:58:15.000000000 +0900
+++ haskelldb-hdbc-2.2.2/Database/HaskellDB/HDBC.hs	2013-01-17 09:24:53.379428100 +0900
@@ -25,8 +25,10 @@
 
 import Database.HDBC as HDBC hiding (toSql)
 
+import Control.Monad.Identity
 import Control.Monad.Trans (MonadIO, liftIO)
 import Data.Char (toLower)
+import Data.Convertible.Base (Convertible)
 import Data.Map (Map)
 import qualified Data.Map as Map
 import Data.Maybe (fromMaybe)
@@ -176,7 +178,7 @@
     stmt <- handleSqlError $ HDBC.prepare conn sql
     handleSqlError $ HDBC.execute stmt []
     rows <- fetchNormalizedAllRowsAL stmt
-    mapM (getRec hdbcGetInstances rel scheme) $ map Map.fromList rows
+    return $ runIdentity $ mapM (getRec hdbcGetInstances rel scheme) $ map Map.fromList rows
   where fetchNormalizedAllRowsAL sth =
           do
           names <- map normalizeField `fmap` getColumnNames sth
@@ -197,7 +199,7 @@
 -- Getting data from a statement
 -----------------------------------------------------------
 
-hdbcGetInstances :: GetInstances HDBCRow
+hdbcGetInstances :: GetInstances Identity HDBCRow
 hdbcGetInstances = 
     GetInstances {
 		  getString        = hdbcGetValue
@@ -209,8 +211,8 @@
 		 , getLocalTime    = hdbcGetValue
 		 }
 
--- hdbcGetValue :: Data.Convertible.Base.Convertible SqlValue a
---             => HDBCRow -> String -> IO (Maybe a)
+hdbcGetValue :: Data.Convertible.Base.Convertible SqlValue a
+             => HDBCRow -> String -> Identity (Maybe a)
 hdbcGetValue m f = case Map.lookup (normalizeField f) m of
                      Nothing -> fail $ "No such field " ++ f
                      Just x  -> return $ HDBC.fromSql x