Query shredding queries in Database-supported Haskell

shredding.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

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

employees :: Q [(Text, Text, Integer)]
employees = table "employees"

{- For some reason this does not work as a table.
   My best guess is that the Postgres `boolean` does not map to the Haskell `Bool`.
   However, I have no clue what other types to use on either side.
   (Oh, and what about NULL values in the database? What does Links do? What *should* anyone do?)

stefan@stefan-work:~/src/dsh-playground$ cabal build && ./dist/build/site/site
Building dsh-playground-0.1.0.0...
Preprocessing executable 'site' for dsh-playground-0.1.0.0...
[1 of 1] Compiling Main             ( shredding.hs, dist/build/site/site-tmp/Main.o )
Linking dist/build/site/site ...
site: The type: FString
is not compatible with the type of column nr: 1 namely: client
 in table contacts.

-}
contacts :: Q [(Text, Text, Bool)]
contacts =
  -- table "contacts"
  toQ [ ("Product", "Pam", False)
      , ("Product", "Pat", True)
      , ("Research", "Rob", False)
      , ("Research", "Roy", False)
      , ("Sales", "Sam", False)
      , ("Sales", "Sid", False)
      , ("Sales", "Sue", True)
      ]

departments :: Q [(Text)]
departments = table "departments"

tasksOfEmp :: Q (Text, Text, Integer) -> Q [Text]
tasksOfEmp (view -> (_, name, _))
  = [ task
    | (view -> (employee, task)) <- tasks
    , employee == name ]

contactsOfDept :: Q Text -> Q [(Text, Bool)]
contactsOfDept (view -> d)
  = [ pair name client
    | (view -> (dept, name, client)) <- contacts
    , dept == d ]

employeesByTask (view -> (employee, _))
  = [ pair employee ddept
    | (view -> (edept, name, _)) <- employees
    , (view -> ddept) <- departments
    , name == employee && edept == ddept ]

employeesOfDept :: Q Text -> Q [(Text, Integer, [Text])]
employeesOfDept (view -> d)
  = [ triple name salary (tasksOfEmp e)
    | e@(view -> (dept, name, salary)) <- employees
    , dept == d ]

isPoor (view -> (_, salary, _)) = salary < 1000

isRich (view -> (_, salary, _)) = salary > 1000000

outliers xs = filter (\x -> isRich x || isPoor x) xs

clients xs = filter (\(view -> (_, client)) -> client) xs

{- Note: In the shredding paper, getTasks does not take the `name` parameter.
Instead, it just expects the list elements to have a `name` field.  I don't know
how to translate that to DSH, so we just take an additional parameter that acts
as an accessor function. -}
getTasks :: (QA a, QA b, QA c) => Q [a] -> (Q a -> Q b) -> (Q a -> Q c) -> Q [(b, c)]
getTasks xs name f = [ pair (name x) (f x)
                     | x <- xs ]

query1 :: Q [(Text, [(Text, Integer, [Text])], [(Text, Bool)])]
query1 = [ triple name (employeesOfDept d) (contactsOfDept d)
         | d@(view -> name) <- departments ]

query2 = [ name
         | (view -> (name, employees, contacts)) <- query1
         , all (\(view -> (_, _, tasks)) -> "abstract" `elem` tasks) employees
         ]

query3 = [ pair name (tasksOfEmp e)
         | e@(view -> (_, name, _)) <- employees ]

query4 = [ pair dept [ employee
                     | (view -> (d, employee, _)) <- employees
                     , dept == d ]
         | (view -> dept) <- departments ]
                                                     
query5 = [ pair task (employeesByTask t)
         | t@(view -> (employee, task)) <- tasks ]

query6 = [ pair name $ (++) (getTasks (outliers employees)
                                      (\(view -> (name, _, _)) -> name)
                                      (\(view -> (_, _, tasks)) -> tasks))
                            (getTasks (clients contacts)
                                      (\(view -> (name, _)) -> name)
                                      (\ _ -> return "buy"))
         | d@(view -> (name, employees, contacts)) <- query1 ]
         
getConn :: IO Connection
getConn = connectPostgreSQL "user = 'stefan' password = '' host = 'localhost' dbname = 'shredding'"

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 = sequence_ [ runQ query1
                 , runQ query2
                 , runQ query3
                 , runQ query4
                 , runQ query5
                 , runQ query6
                 ]

shredding.sql

create table if not exists departments (
  name text);

create table if not exists employees (
  dept text,
  name text,
  salary integer);

create table if not exists tasks (
  employee text,
  task text);

create table if not exists contacts (
  dept text,
  name text,
  client boolean);

insert into departments (name) values
  ('Product'),
  ('Quality'),
  ('Research'),
  ('Sales');

insert into employees (dept, name, salary) values
  ('Product', 'Alex', 20000),
  ('Product', 'Bert', 900),
  ('Research', 'Cora', 50000),
  ('Research', 'Drew', 60000),
  ('Sales', 'Erik', 2000000),
  ('Sales', 'Fred', 700),
  ('Sales', 'Gina', 10000);

insert into tasks (employee, task) values
  ('Alex', 'build'),
  ('Bert', 'build'),
  ('Cora', 'abstract'),
  ('Cora', 'build'),
  ('Cora', 'call'),
  ('Cora', 'dissemble'),
  ('Cora', 'enthuse'),
  ('Drew', 'abstract'),
  ('Drew', 'enthuse'),
  ('Erik', 'call'),
  ('Erik', 'enthuse'),
  ('Fred', 'call'),
  ('Gina', 'call'),
  ('Gina', 'dissemble');

insert into contacts (dept, name, client) values
  ('Product', 'Pam', false),
  ('Product', 'Pat', true),
  ('Research', 'Rob', false),
  ('Research', 'Roy', false),
  ('Sales', 'Sam', false),
  ('Sales', 'Sid', false),
  ('Sales', 'Sue', true);