mirror of
https://github.com/khibino/haskell-relational-record.git
synced 2025-01-07 13:46:41 +03:00
103 lines
2.5 KiB
Haskell
103 lines
2.5 KiB
Haskell
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE RankNTypes #-}
|
|
|
|
import Database.Record
|
|
|
|
import Database.Relational.Query
|
|
import Database.HDBC (IConnection, SqlValue)
|
|
import Data.Int (Int32)
|
|
|
|
import SetA (SetA (SetA), setA)
|
|
import qualified SetA
|
|
import SetB (setB)
|
|
import qualified SetB
|
|
import History (History (History), history)
|
|
|
|
import PgTestDataSource (connect)
|
|
import Database.HDBC.Record.Query (runQuery)
|
|
import Database.HDBC.Session (withConnectionIO, handleSqlError')
|
|
|
|
qa' :: Relation () (Int32, String)
|
|
qa' = relation $ do
|
|
a <- query setA
|
|
return $ a ! SetA.seq' >< a ! SetA.name'
|
|
|
|
qb' :: Relation () (Int32, String)
|
|
qb' = relation $ do
|
|
b <- query setB
|
|
return $ b ! SetB.seq' >< b ! SetB.name'
|
|
|
|
append' :: (forall a . Relation () a -> Relation () a -> Relation () a)
|
|
-> Relation () (Int32, String)
|
|
append' op = relation $ do
|
|
q <- query $ qa' `op` qb'
|
|
asc $ q ! fst'
|
|
return q
|
|
|
|
u :: Relation () (Int32, String)
|
|
u = append' union
|
|
|
|
e :: Relation () (Int32, String)
|
|
e = append' except
|
|
|
|
i :: Relation () (Int32, String)
|
|
i = append' intersect
|
|
|
|
qa :: Relation () SetA
|
|
qa = setA
|
|
|
|
qb :: Relation () SetA
|
|
qb = relation $ do
|
|
b <- query setB
|
|
return $ SetA |$| b ! SetB.seq' |*| b ! SetB.name'
|
|
|
|
append :: (forall a . Relation () a -> Relation () a -> Relation () a)
|
|
-> Relation () SetA
|
|
append op = relation $ do
|
|
q <- query $ qa `op` qb
|
|
asc $ q ! SetA.seq'
|
|
return q
|
|
|
|
uAll :: Relation () SetA
|
|
uAll = append unionAll
|
|
|
|
i2 :: Relation () SetA
|
|
i2 = relation $ do
|
|
qu <- query $ qa `union` qb
|
|
qi <- query $ qa `intersect` qb
|
|
|
|
wheres $ qu ! SetA.seq' .=. qi ! SetA.seq'
|
|
|
|
return qu
|
|
|
|
oldest :: Relation () History
|
|
oldest = relation $ do
|
|
return $ History |$| value 0 |*| value (read "2012-12-01 00:00:00") |*| value "oldest"
|
|
|
|
runAndPrint :: (Show a, IConnection conn, FromSql SqlValue a, ToSql SqlValue p)
|
|
=> conn -> Relation p a -> p -> IO ()
|
|
runAndPrint conn rel param = do
|
|
putStrLn $ "SQL: " ++ show rel
|
|
records <- runQuery conn (relationalQuery rel) param
|
|
mapM_ print records
|
|
putStrLn ""
|
|
|
|
run :: IO ()
|
|
run = handleSqlError' $ withConnectionIO connect
|
|
(\conn -> do
|
|
let run' :: (Show a, FromSql SqlValue a, ToSql SqlValue p)
|
|
=> Relation p a -> p -> IO ()
|
|
run' = runAndPrint conn
|
|
run' qa' ()
|
|
run' qb' ()
|
|
run' u ()
|
|
run' uAll ()
|
|
run' e ()
|
|
run' i ()
|
|
run' i2 ()
|
|
run' (history `union` oldest) ()
|
|
)
|
|
|
|
main :: IO ()
|
|
main = run
|