haskell-relational-record #1 2013-05-17時点のものを使用。Exprが推論されるようになったので expr や toExpr を書かなくてすむ。

gistfile1.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MonadComprehensions #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Database.Test.Query where

import Data.Int                           (Int32)
import Data.Time                          (Day)
import Database.HDBC.Record.Query         (runQuery)
import Database.HDBC.Session              (withConnectionIO)
import Database.HDBC.SqlValue             (SqlValue)
import Database.Record.FromSql            (FromSql)
import Database.Record.ToSql              (ToSql)
import Database.Relational.Query          (PrimeRelation, (!), (.>.), (.<.), (>*<),
                                           and, asc, from, fromRelation, placeholder,
                                           relation, wheres)
import Database.Test.PostgreSQL           (connect)

import Prelude                     hiding (and)

import qualified Database.Test.Schema  as SC

{-# ANN module "HLint: ignore Eta reduce" #-}

test :: (ToSql SqlValue p, FromSql SqlValue a) => PrimeRelation p a -> p -> (a -> IO b) -> IO ()
test prel param printer = withConnectionIO connect $ \conn -> do
    rows <- runQuery conn param $ fromRelation prel
    mapM_ printer rows
    return ()

--
-- >>> test t0 () printT0
--
t0 :: PrimeRelation () SC.TTenant
t0 = relation $ from SC.tableOfTTenant

printT0 :: SC.TTenant -> IO ()
printT0 t =
    putStrLn $ show (SC.id t)
         ++ ", " ++ SC.tenantName t
         ++ ", " ++ show (SC.serviceEndDay t)

--
-- >>> :m + Date.Time 
-- >>> utctime <- getCurrentTime
-- >>> let today = utctDay utctime
-- >>> test t1a (today,today) printT1
-- >>> test t1b (today,today) printT1
--
t1a :: PrimeRelation (Day,Day) ((Int32, String), Day)
t1a = relation
    [ (t ! SC.id') >*< (t ! SC.tenantName') >*< (t ! SC.serviceEndDay')
    | t  <- from SC.tableOfTTenant
    , () <- wheres $ and ((t ! SC.serviceStartDay') .<. placeholder)
                         ((t ! SC.serviceEndDay')   .>. placeholder)] 

t1b :: PrimeRelation (Day,Day) ((Int32, String), Day)
t1b = relation $ do
    t <- from SC.tableOfTTenant
    wheres $ and ((t ! SC.serviceStartDay') .<. placeholder)
                 ((t ! SC.serviceEndDay')   .>. placeholder)
    asc (t ! SC.id')
    return $ (t ! SC.id') >*< (t ! SC.tenantName') >*< (t ! SC.serviceEndDay')

printT1 :: ((Int32, String), Day) -> IO ()
printT1 ((i,n),d) =
    putStrLn $ show i ++ ", " ++ n ++ ", " ++ show d