Example query from Haskell boards the Ferry, George Giorgidze et al., IFL 2010

hbtf.hs

{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE MonadComprehensions   #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE RebindableSyntax      #-}
{-# LANGUAGE TemplateHaskell       #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE UndecidableInstances  #-}
{-# LANGUAGE ViewPatterns          #-}

module Main where

import qualified Prelude as P
import Database.DSH
import Database.DSH.Compiler
import Database.HDBC.PostgreSQL

meanings :: Q [(Text, Text)]
meanings = table "meanings"

features :: Q [(Text, Text)]
features = table "features"

facilities :: Q [(Text, Text)]
facilities = table "facilities"

descrFacility :: Q Text -> Q [Text]
descrFacility f = [mean | (view -> (feat, mean)) <- meanings, -- table "meanings",
                          (view -> (fac, feat')) <- features, -- table "features",
                          feat == feat' && fac == f]

-- not quite [ (the cat, nub (concatMap descrFacility fac)) | ...] but it works
query :: Q [(Text, [Text])]
query = [ pair cat (nub (concat [ (descrFacility f)
                                | (view -> (_, f)) <- fac ]))
        | (view -> (cat, fac)) <- groupWithKey (\(view -> (c, _)) -> c) facilities]

getConn :: IO Connection
getConn = connectPostgreSQL "user = 'stefan' password = '' host = 'localhost' dbname = 'hbtf'"

runQ :: (Show a,QA a) => Q a -> IO ()
runQ q = getConn P.>>= \conn -> (fromQ conn q P.>>= P.print) P.>> disconnect conn

main :: IO ()
main = runQ query