haskell-hdbc-tool #2: ghc-modがplaceholderの型を決められなかったのでpのままだけど、この例の場合は (Date.Time.Day, Date.Time.Day)。 (Github 2013-05-11時点のhaskell-hdbc-toolを使用)

ghci

$ cabal-dev ghci

on the commandline:
    Warning: -O conflicts with --interactive; -O ignored.
GHCi, version 7.4.2: http://www.haskell.org/ghc/  :? for help
Loading package ghc-prim ... linking ... done.
Loading package integer-gmp ... linking ... done.
Loading package base ... linking ... done.
Loading package array-0.4.0.0 ... linking ... done.
Loading package deepseq-1.3.0.0 ... linking ... done.
Loading package containers-0.4.2.1 ... linking ... done.
Loading package pretty-1.1.1.0 ... linking ... done.
Loading package template-haskell ... linking ... done.
Loading package names-th-0.0.1.0 ... linking ... done.
Loading package DB-record-0.0.1.0 ... linking ... done.
Loading package bytestring-0.9.2.1 ... linking ... done.
Loading package transformers-0.3.0.0 ... linking ... done.
Loading package mtl-2.1.2 ... linking ... done.
Loading package old-locale-1.0.0.4 ... linking ... done.
Loading package old-time-1.1.0.0 ... linking ... done.
Loading package text-0.11.2.3 ... linking ... done.
Loading package time-1.4 ... linking ... done.
Loading package convertible-1.0.11.1 ... linking ... done.
Loading package utf8-string-0.3.7 ... linking ... done.
Loading package HDBC-2.3.1.2 ... linking ... done.
Loading package HDBC-session-0.0.1.0 ... linking ... done.
Loading package sql-words-0.0.1.0 ... linking ... done.
Loading package relational-join-0.0.1.0 ... linking ... done.
Loading package HDBC-schema-th-0.0.1.0 ... linking ... done.
Loading package parsec-3.1.3 ... linking ... done.
Loading package HDBC-postgresql-2.3.2.1 ... linking ... done.
Ok, modules loaded: Database.Test.Query, Database.Test.PostgreSQL, Database.Test.Schema.
Prelude Database.Test.Query> :set prompt "ghci> "
ghci> :m + Data.Time Database.HDBC.SqlValue
ghci> utctime <- getCurrentTime
ghci> let today = utctDay utctime
ghci> test queryAvailableTenant2 (today,today) printAvailableTenant
1, AAAA, 2018-02-28
4, DDDD, 2015-12-31
7, GGGG, 2015-12-31
(略)

Query.hs

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

module Database.Test.Query where

import Data.Int                             (Int32)
import Data.Time                            (Day, UTCTime(utctDay), getCurrentTime)
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            (Query)
import Database.Relational.Query.Expr       ((.>.), (.<.), and)
import Database.Relational.Query.Join       ((!), (>*<), asc, expr, from, relation, wheres)
import Database.Relational.Query.Projection (placeholder, toExpr)
import Database.Relational.Query.Type       (fromRelation)
import Database.Test.PostgreSQL             (connect)

import Prelude                       hiding (and)

import qualified Database.Test.Schema     as SC

{-# ANN module "HLint: ignore Eta reduce" #-}
--{-# ANN module "HLint: ignore Redundant $" #-}
--{-# ANN module "HLint: ignore Use print" #-}

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

queryTTenant :: Query () SC.TTenant
queryTTenant = fromRelation $ relation $ from SC.tableOfTTenant

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

queryAvailableTenant1 :: Query p ((Int32, String), Day)
queryAvailableTenant1 = fromRelation $ relation
    [ (t ! SC.id') >*< (t ! SC.tenantName') >*< (t ! SC.serviceEndDay')
    | t  <- from SC.tableOfTTenant
    , () <- wheres $ and (expr (t ! SC.serviceStartDay') .<. toExpr placeholder)
                         (expr (t ! SC.serviceEndDay')   .>. toExpr placeholder)]

queryAvailableTenant2 :: Query p ((Int32, String), Day)
queryAvailableTenant2 = fromRelation $ relation $ do
    t <- from SC.tableOfTTenant
    wheres $ and (expr (t ! SC.serviceStartDay') .<. toExpr placeholder)
                 (expr (t ! SC.serviceEndDay')   .>. toExpr placeholder)
    asc $ expr (t ! SC.id')
    return $ (t ! SC.id') >*< (t ! SC.tenantName') >*< (t ! SC.serviceEndDay')

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