Change definition of Relation type.

relational-join-HDBC-pgTest/sample/1/querySample.hs

@@ -40,24 +40,24 @@ userGroup0 =
   , ()  <- 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.
+-- 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'
+--   , () <- on $ u !? User.id' .=. flatten (mg !? fst') !? userId'
 
-  , ()  <- asc $ u !? User.id'
-  ]
+--   , ()  <- asc $ u !? User.id'
+--   ]
 
 runAndPrint :: (Show a, IConnection conn, FromSql SqlValue a) => conn -> Relation a -> IO ()
 runAndPrint conn rel = do
-  putStrLn $ "SQL: " ++ show rel
+  putStrLn $ "SQL: " ++ toSQL rel
   records  <- runQuery conn () (fromRelation rel)
   mapM_ print records
   putStrLn ""
@@ -66,7 +66,7 @@ run :: IO ()
 run =  withConnectionIO connect
        (\conn -> do
            runAndPrint conn userGroup0
-           runAndPrint conn userGroup1
+--           runAndPrint conn userGroup1
        )
 
 main :: IO ()

relational-join/relational-join.cabal

@@ -29,7 +29,6 @@ library
                        Database.Relational.Query.Join
                        Database.Relational.Query.Expr
                        Database.Relational.Query.Expr.Unsafe
-                       Database.Relational.Query.Relation
                        Database.Relational.Query.Sub
                        Database.Relational.Query.Type
                        Database.Relational.Query.Derives

relational-join/src/Database/Relational/Query.hs

@@ -9,7 +9,6 @@ module Database.Relational.Query (
   module Database.Relational.Query.Sub,
   module Database.Relational.Query.Projection,
   module Database.Relational.Query.Projectable,
-  module Database.Relational.Query.Relation,
   module Database.Relational.Query.Join,
   module Database.Relational.Query.Type,
   module Database.Relational.Query.Derives
@@ -24,10 +23,9 @@ import Database.Relational.Query.Constraint
    Primary, Unique, NotNull)
 import Database.Relational.Query.AliasId (Qualified)
 import Database.Relational.Query.Expr
-import Database.Relational.Query.Sub (SubQuery, unitSQL, width, queryWidth)
+import Database.Relational.Query.Sub (SubQuery, unitSQL, queryWidth)
 import Database.Relational.Query.Projection (Projection)
 import Database.Relational.Query.Projectable
-import Database.Relational.Query.Relation (Relation, PrimeRelation, toSQL, fromTable)
 import Database.Relational.Query.Join
 import Database.Relational.Query.Type
   (Query, untypeQuery, fromRelation,

relational-join/src/Database/Relational/Query/Derives.hs

@@ -12,9 +12,8 @@ module Database.Relational.Query.Derives (
 import Database.Record (PersistableWidth)
 import Database.Relational.Query.Table (Table)
 import qualified Database.Relational.Query.Table as Table
-import Database.Relational.Query.Relation (Relation, PrimeRelation)
 import Database.Relational.Query.Projectable (placeholder, (.=.))
-import Database.Relational.Query.Join (relation, query, wheres, (!))
+import Database.Relational.Query.Join (Relation, PrimeRelation, relation, query, wheres, (!))
 import Database.Relational.Query.Constraint
    (Key, Primary, Unique, projectionKey, uniqueKey,
     HasConstraintKey(constraintKey))

relational-join/src/Database/Relational/Query/Join.hs

@@ -5,12 +5,19 @@ module Database.Relational.Query.Join (
   on, wheres, asc, desc,
   table,
 
-  record, record', expr, compose, (>*<), (!), (!?), flatten,
+  expr,
+  compose, (>*<), (!), (!?), flatten,
   relation, relation',
 
   query, query', queryMaybe, queryMaybe', from,
 
-  queryMerge, queryMergeMaybe
+  PrimeRelation, Relation,
+
+  toSQL,
+
+  toSubQuery,
+
+  nested, width
   ) where
 
 import Prelude hiding (product)
@@ -20,8 +27,8 @@ import Control.Applicative (Applicative (pure, (<*>)))
 import Database.Record (PersistableWidth)
 
 import Database.Relational.Query.Internal.Context
-  (Context, primContext, currentAliasId, product, restriction, orderByRev,
-   nextAliasContext, updateProduct', updateRestriction', updateOrderBy')
+  (Context, Order(Asc, Desc), primContext, currentAliasId, product, orderByRev,
+   nextAliasContext, updateProduct', updateRestriction', updateOrderBy', composeSQL)
 
 import Database.Relational.Query.AliasId (AliasId, Qualified)
 import qualified Database.Relational.Query.AliasId as AliasId
@@ -40,8 +47,8 @@ import Database.Relational.Query.Projectable (Projectable(project))
 
 import Database.Relational.Query.Pi (Pi)
 
-import Database.Relational.Query.Relation (Relation, PrimeRelation, finalizeRelation, Order(Asc, Desc))
-import qualified Database.Relational.Query.Relation as Relation
+import Database.Relational.Query.Sub (SubQuery)
+import qualified Database.Relational.Query.Sub as SubQuery
 
 
 newtype QueryJoin a =
@@ -59,9 +66,6 @@ updateContext :: (Context -> Context) -> QueryJoin ()
 updateContext uf =
   QueryJoin $ \st -> ((), uf st)
 
-updateProduct :: NodeAttr -> Qualified (PrimeRelation p r) -> QueryJoin ()
-updateProduct attr qrel = updateContext (updateProduct' (`growProduct` (attr, fmap Relation.toSubQuery qrel)))
-
 updateJoinRestriction :: Expr Bool -> QueryJoin ()
 updateJoinRestriction e = updateContext (updateProduct' d)  where
   d  Nothing  = error "addProductRestriction: product is empty!"
@@ -87,18 +91,15 @@ desc :: Expr t -> QueryJoin ()
 desc =  updateOrderBy Desc
 
 
+data PrimeRelation p r = SubQuery SubQuery
+                       | PrimeRelation (QueryJoin (Projection r))
+
+type Relation r = PrimeRelation () r
+
 data PlaceHolders p = PlaceHolders
 
 table :: Table r -> Relation r
-table =  Relation.fromTable
-
-record' :: Qualified (PrimeRelation p r) -> (PlaceHolders p, Projection r)
-record' qrel =
-  (PlaceHolders,
-   Projection.fromQualifiedSubQuery (fmap Relation.toSubQuery qrel))
-
-record :: Qualified (Relation r) -> Projection r
-record =  snd . record'
+table =  SubQuery . SubQuery.fromTable
 
 expr :: Projection ft -> Expr ft
 expr =  project
@@ -141,47 +142,70 @@ qualify rel =
   do n <- newAlias
      return $ AliasId.qualify rel n
 
-queryWithAttr :: NodeAttr -> PrimeRelation p r -> QueryJoin (Qualified (PrimeRelation p r))
-queryWithAttr attr rel =
-  do qrel <- qualify rel
-     updateProduct attr qrel
-     return qrel
-
-query :: Relation r -> QueryJoin (Projection r)
-query =  fmap record . queryWithAttr Just'
-
-query' :: PrimeRelation p r -> QueryJoin (PlaceHolders p, Projection r)
-query' =  fmap record' . queryWithAttr Just'
-
-queryMaybe :: Relation r -> QueryJoin (Projection (Maybe r))
-queryMaybe =  fmap (record . fmap Relation.toMaybe) . queryWithAttr Maybe
-
-queryMaybe' :: PrimeRelation p r -> QueryJoin (PlaceHolders p, Projection (Maybe r))
-queryMaybe' =  fmap (record' . fmap Relation.toMaybe) . queryWithAttr Maybe
-
-from :: Table r -> QueryJoin (Projection r)
-from =  query . table
-
 unsafeMergeAnother :: NodeAttr -> QueryJoin a -> QueryJoin a
 unsafeMergeAnother attr q1 =
   QueryJoin
   $ \st0 -> let mp0       = product st0
-                (pj, st1) = runQueryJoin q1 (st0 { product = Nothing})
-            in  (pj, maybe st1 (\p0 -> updateProduct' (Product.growLeft p0 attr) st1) mp0)
+                or0       = orderByRev st0
+                (pj, st1) = runQueryJoin q1 (st0 { product = Nothing, orderByRev = [] })
+            in  (pj,
+                 (maybe st1 (\p0 ->
+                              updateProduct' (Product.growLeft p0 attr)
+                              st1
+                            ) mp0) { orderByRev = or0 ++ orderByRev st1 }
+                )
 
 queryMergeWithAttr :: NodeAttr -> QueryJoin (Projection r) -> QueryJoin (Projection r)
 queryMergeWithAttr =  unsafeMergeAnother
 
-queryMerge :: QueryJoin (Projection r) -> QueryJoin (Projection r)
-queryMerge =  queryMergeWithAttr Just'
+queryWithAttr :: NodeAttr -> PrimeRelation p r -> QueryJoin (PlaceHolders p, Projection r)
+queryWithAttr attr = fmap ((,) PlaceHolders) . d where
+  d (SubQuery sub)    = do
+    qsub <- qualify sub
+    updateContext (updateProduct' (`growProduct` (attr, qsub)))
+    return $ Projection.fromQualifiedSubQuery qsub
+  d (PrimeRelation q) =
+    queryMergeWithAttr attr q
 
-queryMergeMaybe :: QueryJoin (Projection a) -> QueryJoin (Projection (Maybe a))
-queryMergeMaybe =  fmap Projection.just . queryMergeWithAttr Maybe
+query' :: PrimeRelation p r -> QueryJoin (PlaceHolders p, Projection r)
+query' =  queryWithAttr Just'
 
-relation :: QueryJoin (Projection r) -> PrimeRelation a r
-relation q = finalizeRelation projection product' (restriction st) (orderByRev st)  where
-  (projection, st) = runQueryPrime q
-  product' = maybe (error "relation: empty product!") (Product.tree . Product.nodeTree) $ product st
+query :: PrimeRelation p r -> QueryJoin (Projection r)
+query =  fmap snd . query'
+
+queryMaybe' :: PrimeRelation p r -> QueryJoin (PlaceHolders p, Projection (Maybe r))
+queryMaybe' pr =  do
+  (ph, pj) <- queryWithAttr Maybe pr
+  return (ph, Projection.just pj)
+
+queryMaybe :: PrimeRelation p r -> QueryJoin (Projection (Maybe r))
+queryMaybe =  fmap snd . queryMaybe'
+
+relation :: QueryJoin (Projection r) -> PrimeRelation p r
+relation =  PrimeRelation
 
 relation' :: QueryJoin (PlaceHolders p, Projection r) -> PrimeRelation p r
-relation' =  relation . fmap snd
+relation' =  PrimeRelation . fmap snd
+
+from :: Table r -> QueryJoin (Projection r)
+from =  query . table
+
+toSQL :: PrimeRelation p r -> String
+toSQL =  d  where
+  d (SubQuery sub)     = SubQuery.toSQL sub
+  d (PrimeRelation qp) = uncurry composeSQL (runQueryPrime qp)
+
+instance Show (PrimeRelation p r) where
+  show = toSQL
+
+toSubQuery :: PrimeRelation p r -> SubQuery
+toSubQuery =  d  where
+  d (SubQuery sub)     = sub
+  d (PrimeRelation qp) = SubQuery.subQuery (composeSQL pj c) (Projection.width pj) where
+    (pj, c) = runQueryPrime qp
+
+width :: PrimeRelation p r -> Int
+width =  SubQuery.width . toSubQuery
+
+nested :: PrimeRelation p r -> PrimeRelation p r
+nested =  SubQuery . toSubQuery

relational-join/src/Database/Relational/Query/Relation.hs

@@ -1,87 +0,0 @@
-module Database.Relational.Query.Relation (
-
-  Order (..),
-  PrimeRelation, Relation,
-
-  toMaybe,
-  fromTable,
-
-  toSubQuery,
-  toSQL,
-
-  finalizeRelation
-  ) where
-
-import Prelude hiding (product, and)
-import Data.List (intercalate)
-
-import Database.Relational.Query.Expr (Expr)
-
-import Database.Relational.Query.Table (Table)
-import qualified Database.Relational.Query.Table as Table
-
-import Database.Relational.Query.Sub (SubQuery, subQuery)
-import qualified Database.Relational.Query.Sub as SubQuery
-
-import Database.Relational.Query.Product (Product)
-
-import Database.Relational.Query.Projection (Projection)
-import qualified Database.Relational.Query.Projection as Projection
-
-import Language.SQL.Keyword (Keyword(..), unwordsSQL)
-import qualified Language.SQL.Keyword as SQL
-
-import Database.Relational.Query.Internal.Context (Order(..), composedSQL)
-
-
-data PrimeRelation a r = Table (Table r)
-                       | Relation
-                         { projection  :: Projection r
-                         , product     :: Product
-                         , restriction :: Maybe (Expr Bool)
-                         , orderByRev  :: [(Order, String)]
-                         }
-
-type Relation = PrimeRelation ()
-
-toMaybe :: PrimeRelation a r -> PrimeRelation a (Maybe r)
-toMaybe =  d  where
-  d (Table t)                       = Table $ Table.toMaybe t
-  d r@(Relation { projection = p }) = r { projection = Projection.toMaybe p }
-
-width :: PrimeRelation a r -> Int
-width =  d  where
-  d (Table t)                      = Table.width t
-  d (Relation { projection = p } ) = Projection.width p
-
-fromTable :: Table r -> Relation r
-fromTable =  Table
-
-toSubQuery :: PrimeRelation a r -> SubQuery
-toSubQuery =  d  where
-  d (Table t)          = SubQuery.fromTable t
-  d rel@(Relation { }) = subQuery
-                         (composedSQL
-                          (projection rel)
-                          (product rel)
-                          (restriction rel)
-                          (orderByRev rel)
-                         )
-                         (width rel)
-
-finalizeRelation :: Projection r -> Product -> Maybe (Expr Bool) -> [(Order, String)] -> PrimeRelation a r
-finalizeRelation =  Relation
-
-fromTableToSql :: Table r -> String
-fromTableToSql t =
-  unwordsSQL
-  $ [SELECT, SQL.word $ ", " `intercalate` Table.columns t,
-     FROM, SQL.word $ Table.name t]
-
-toSQL :: PrimeRelation a r -> String
-toSQL =  d  where
-  d (Table t)           = fromTableToSql t
-  d (rel@(Relation {})) = SubQuery.toSQL . toSubQuery $ rel
-
-instance Show (PrimeRelation a r) where
-  show = show . toSubQuery

relational-join/src/Database/Relational/Query/Sub.hs

@@ -35,7 +35,7 @@ width =  d  where
 
 toSQLs :: SubQuery -> (String, String)
 toSQLs =  d  where
-  d (Table u)               = let n = Table.name' u in (n, n)
+  d (Table u)               = (Table.name' u, Table.fromTableToSql u)
   d (SubQuery { sql' = q }) = ('(' : q ++ [')'], q)
 
 unitSQL :: SubQuery -> String

relational-join/src/Database/Relational/Query/TH.hs

@@ -48,9 +48,10 @@ import Database.Record.TH
    defineHasKeyConstraintInstance)
 
 import Database.Relational.Query
-  (Table, Pi, Relation, PrimeRelation, fromTable,
+  (Table, Pi, Relation, PrimeRelation,
    toSQL, Query, fromRelation, Update, Insert, typedInsert,
    HasConstraintKey(constraintKey), projectionKey, Primary, NotNull)
+import qualified Database.Relational.Query as Query
 
 import Database.Relational.Query.Constraint (Key, defineConstraintKey)
 import qualified Database.Relational.Query.Table as Table
@@ -142,7 +143,7 @@ defineTableTypes tableVar' relVar' recordType table columns = do
             [| Table.table $(stringE table) $(listE $ map stringE (map (fst . fst) columns)) |]
   let relVar   = varName relVar'
   relDs   <- simpleValD relVar   [t| Relation $(recordType) |]
-             [| fromTable $(toVarExp tableVar') |]
+             [| Query.table $(toVarExp tableVar') |]
   return $ tableDs ++ relDs
 
 tableSQL :: String -> String -> String

relational-join/src/Database/Relational/Query/Table.hs

@@ -2,11 +2,17 @@ module Database.Relational.Query.Table (
   Untyped, name', width', columns', (!),
 
   Table, unType, name, shortName, width, columns, index, table, toMaybe,
+
+  fromTableToSql
   ) where
 
+import Data.List (intercalate)
 import Data.Array (Array, listArray, elems)
 import qualified Data.Array as Array
 
+import Language.SQL.Keyword (Keyword(..), unwordsSQL)
+import qualified Language.SQL.Keyword as SQL
+
 data Untyped = Untyped
                { name'       :: String
                , width'      :: Int
@@ -44,3 +50,10 @@ table :: String -> [String] -> Table r
 table n f = Table $ Untyped n w fa  where
   w  = length f
   fa = listArray (0, w - 1) f
+
+
+fromTableToSql :: Untyped -> String
+fromTableToSql t =
+  unwordsSQL
+  $ [SELECT, SQL.word $ ", " `intercalate` columns' t,
+     FROM, SQL.word $ name' t]

relational-join/src/Database/Relational/Query/Type.hs

@@ -6,8 +6,7 @@ module Database.Relational.Query.Type (
   Insert(untypeInsert), unsafeTypedInsert, typedInsert
   ) where
 
-import Database.Relational.Query.Relation (PrimeRelation)
-import qualified Database.Relational.Query.Relation as Relation
+import Database.Relational.Query.Join (PrimeRelation, toSQL)
 import Database.Relational.Query.Table (Table)
 import Database.Relational.Query.SQL (singleKeyUpdateSQL, insertSQL)
 
@@ -21,7 +20,7 @@ instance Show (Query p a) where
   show = untypeQuery
 
 fromRelation :: PrimeRelation p r -> Query p r
-fromRelation =  unsafeTypedQuery . Relation.toSQL
+fromRelation =  unsafeTypedQuery . toSQL
 
 
 newtype Update p a = Update { untypeUpdate :: String }