diff --git a/relational-join-HDBC-pgTest/relational-join-HDBC-pgTest.cabal b/relational-join-HDBC-pgTest/relational-join-HDBC-pgTest.cabal index 7c293a42..808aad4f 100644 --- a/relational-join-HDBC-pgTest/relational-join-HDBC-pgTest.cabal +++ b/relational-join-HDBC-pgTest/relational-join-HDBC-pgTest.cabal @@ -21,6 +21,7 @@ Executable sample1 , names-th , DB-record , relational-join + , HDBC , HDBC-session , HDBC-postgresql , relational-query-HDBC diff --git a/relational-join-HDBC-pgTest/sample/1/querySample.hs b/relational-join-HDBC-pgTest/sample/1/querySample.hs index 4073405d..832328bb 100644 --- a/relational-join-HDBC-pgTest/sample/1/querySample.hs +++ b/relational-join-HDBC-pgTest/sample/1/querySample.hs @@ -1,6 +1,10 @@ {-# LANGUAGE MonadComprehensions #-} +{-# LANGUAGE FlexibleContexts #-} + +import Database.Record import Database.Relational.Query +import Database.HDBC (IConnection, SqlValue) import qualified User import User (User, user) @@ -12,27 +16,58 @@ import PgTestDataSource (connect) import Database.HDBC.Record.Query (runQuery) import Database.HDBC.Session (withConnectionIO) -um :: Relation (User, Maybe Membership) -um = relation $ - [ u >*< m - | u <- query user - , m <- queryMaybe membership - , () <- on $ just (u ! User.id') .=. m !? userId' - ] -r0 :: Relation (Maybe User, Maybe Group) -r0 = relation $ - [ (um' !? fst') >*< g - | um' <- queryMaybe um - , g <- queryMaybe group - , () <- on $ flatten (um' !? snd') !? groupId' .=. g !? Group.id' - ] +groupMemberShip :: QueryJoin (Projection (Maybe Membership, Group)) +groupMemberShip = + [ m >*< g + | m <- queryMaybe membership + , g <- query group + , () <- on $ m !? groupId' .=. just (g ! Group.id') + ] + +userGroup0 :: Relation (Maybe User, Maybe Group) +userGroup0 = + relation $ + [ u >*< mg !? snd' + | u <- queryMaybe user + , mg <- queryMaybe $ relation groupMemberShip + -- Call one subquery via relation layer + -- Simple implementation. + -- Complex SQL. Nested table form joins. + + , () <- on $ u !? User.id' .=. flatten (mg !? fst') !? userId' + + , () <- asc $ u !? User.id' + ] + +userGroup1 :: Relation (Maybe User, Maybe Group) +userGroup1 = + relation $ + [ u >*< mg !? snd' + | u <- queryMaybe user + , mg <- queryMergeMaybe groupMemberShip + -- Directly merge another QueryJoin monad. + -- Complex implementation. + -- Simple SQL. Flat table form joins. + + , () <- on $ u !? User.id' .=. flatten (mg !? fst') !? userId' + + , () <- asc $ u !? User.id' + ] + +runAndPrint :: (Show a, IConnection conn, FromSql SqlValue a) => conn -> Relation a -> IO () +runAndPrint conn rel = do + putStrLn $ "SQL: " ++ show rel + records <- runQuery conn () (fromRelation rel) + mapM_ print records + putStrLn "" run :: IO () run = withConnectionIO connect (\conn -> do - records <- runQuery conn () (fromRelation r0) - mapM_ print records) + runAndPrint conn userGroup0 + runAndPrint conn userGroup1 + ) main :: IO () main = run