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

data Employee = Employee { department :: Text
                         , name :: Text
                         , salary :: Integer
                         } deriving (Show)

deriveDSH ''Employee

employees' :: Q [Employee]
employees' = [ employee d n s
             | (view -> (d, n, s)) <- employees ]

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 :: Q (Text, Text) -> Q [(Text, Text)]
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

foo = [ d
        -- This works, the other two don't.
        -- What I really want to do is of course use record wildcards...
        -- https://ocharles.org.uk/blog/posts/2014-12-04-record-wildcards.html
      | (view -> (d, _, _)) <- employees'
      -- | (Employee d _ _) <- employees'
      -- | (view -> (Employee d _ _)) <- employees'
      ]
{- Or something like this, but there's no lift, fmap,...  It kind of makes
sense: we don't know how to lift arbitrary functions. However, accessors
*should* be possible. Otherwise we can only use nice types to "toplevel"
queries, not functions that we want to use as parts of queries. -}
      -- [ (lift department) e
      -- | e <- employees' ]

{- This works too, but is no better than the view patterns.. -}
-- [ elim e (\ a b c -> a)
-- | e <- employees' ]

main :: IO ()
main = sequence_ [ runQ query1
                 , runQ query2
                 , runQ query3
                 , runQ query4
                 , runQ query5
                 , runQ query6
                 , runQ foo
                 ]