FirstClassWhere.hs

{-# LANGUAGE FlexibleContexts #-}

module FirstClassWhere where

import Control.Applicative ((<$>))

import Database.Relational.Query

import Data.Int
import Data.Time
import Model (Person, person)
import qualified Model as Person


type Sex = Int32

whereBySex :: MonadRestrict Flat m
           => Projection Flat Person
           -> m (PlaceHolders Sex)
whereBySex p = (fst <$>) . placeholder
               $ \ph' -> wheres $ p ! Person.sex' .=. ph'

whereBirthBetween :: MonadRestrict Flat m
                  => Projection Flat Person
                  -> m (PlaceHolders (Day, Day))
whereBirthBetween p =
  (fst <$>) . placeholder $ \ph' -> do
    let birth = p ! Person.day'
    wheres $ ph' ! fst' .<=. birth `and'` birth .<=. ph' ! snd'

findBySex :: Relation Sex Person
findBySex =  relation' $ do
  p   <- query person
  sph <- whereBySex p
  return (sph, p)

findByBirthBetween :: Relation (Day, Day) Person
findByBirthBetween =  relation' $ do
  p   <- query person
  bph <- whereBirthBetween p
  return (bph, p)

findBySexAndBirthBetween :: Relation (Sex, (Day, Day)) Person
findBySexAndBirthBetween = relation' $ do
  p   <- query person
  sph <- whereBySex p
  bph <- whereBirthBetween p
  return (sph >< bph, p)

Model.hs

{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}

module Model where

import Data.Int (Int32)

import Data.Time

import Database.HDBC.Record.Persistable ()
import Database.Relational.Query (defaultConfig)
import Database.Relational.Query.TH (defineTableDefault)


$(defineTableDefault defaultConfig "TEST" "person"
  [ ("name",         [t| String |])
  , ("day" ,         [t| Day  |])
  , ("sex" ,         [t| Int32 |])
  ] [] [0] $ Just 0)