Treat unit type as zero-width record and defines Extended relation

type which requires parameter type.

DB-record/src/Database/Record/FromSql.hs

@@ -96,6 +96,9 @@ instance (HasKeyConstraint NotNull a, FromSql q a, PersistableType q)
          => FromSql q (Maybe a)  where
   recordFromSql = outer recordFromSql $ constraintKey
 
+instance FromSql q () where
+  recordFromSql = recordFromSql'
+
 takeRecord :: FromSql q a => [q] -> (a, [q])
 takeRecord =  runTakeRecord recordFromSql
 

DB-record/src/Database/Record/Persistable.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 
 -- |
@@ -77,6 +78,9 @@ a <&> b = PersistableRecordWidth $ runPersistableRecordWidth a + runPersistableR
 maybeWidth :: PersistableRecordWidth a -> PersistableRecordWidth (Maybe a)
 maybeWidth =  PersistableRecordWidth . runPersistableRecordWidth
 
+voidWidth :: PersistableRecordWidth ()
+voidWidth =  persistableRecordWidth 0
+
 
 data PersistableRecord q a =
   PersistableRecord
@@ -99,6 +103,9 @@ persistableSingletonFromValue :: PersistableRecordWidth (Singleton a) -> Persist
 persistableSingletonFromValue pw pv =
   persistableRecord pw (singleton . toValue pv . head) ((:[]) . fromValue pv . runSingleton)
 
+persistableVoid :: PersistableRecord q ()
+persistableVoid =  persistableRecord voidWidth (const ()) (const [])
+
 
 class Eq q => PersistableType q where
   persistableType :: PersistableSqlType q
@@ -119,6 +126,9 @@ instance (PersistableWidth a, PersistableWidth b) => PersistableWidth (a, b) whe
 instance PersistableWidth a => PersistableWidth (Maybe a) where
   persistableWidth = maybeWidth persistableWidth
 
+instance PersistableWidth () where
+  persistableWidth = voidWidth
+
 
 class PersistableType q => PersistableValue q a where
   persistableValue :: PersistableSqlValue q a
@@ -139,6 +149,9 @@ derivedPersistableSingleton =  persistableSingletonFromValue persistableWidth pe
 class PersistableWidth a => Persistable q a where
   persistable :: PersistableRecord q a
 
+instance Persistable q () where
+  persistable = persistableVoid
+
 
 takeRecord :: PersistableRecord q a -> [q] -> (a, [q])
 takeRecord rec vals = (toRecord rec va, vr) where

DB-record/src/Database/Record/ToSql.hs

@@ -56,6 +56,8 @@ instance (ToSql q a, ToSql q b) => ToSql q (a, b) where
 recordToSql' :: Persistable q a => RecordToSql q a
 recordToSql' =  recordSerializer persistable
 
+instance ToSql q () where
+  recordToSql = recordToSql'
 
 updateValuesByUnique :: RecordToSql q ra
               -> KeyConstraint Unique ra

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

@@ -19,6 +19,6 @@ import Database.Relational.Query.Sub (SubQuery, unitSQL, width, queryWidth)
 import Database.Relational.Query.Projection
   (Projectable (project), SqlProjectable (unsafeSqlValue),
    value, valueTrue, valueFalse, valueNull, placeholder)
-import Database.Relational.Query.Relation (Relation)
+import Database.Relational.Query.Relation (Relation, PrimeRelation)
 import Database.Relational.Query.Join
 import Database.Relational.Query.Type (Query, untypeQuery, fromRelation)

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

@@ -7,9 +7,9 @@ module Database.Relational.Query.Join (
 
   record, expr, compose, (>*<), (!), (!?), relation,
 
-  inner, outer, from,
+  inner, outer, from
 
-  runQuery
+  -- runQuery
   ) where
 
 import Prelude hiding (product)
@@ -23,7 +23,7 @@ import Database.Relational.Query.AliasId (AliasId, newAliasId, Qualified)
 import qualified Database.Relational.Query.AliasId as AliasId
 
 import Database.Relational.Query.Table (Table)
-import Database.Relational.Query.Sub (SubQuery)
+-- import Database.Relational.Query.Sub (SubQuery)
 
 import Database.Relational.Query.Expr (Expr, showExpr)
 import qualified Database.Relational.Query.Expr as Expr
@@ -37,7 +37,7 @@ import qualified Database.Relational.Query.Projection as Projection
 
 import Database.Relational.Query.Pi (Pi)
 
-import Database.Relational.Query.Relation (Relation, finalizeRelation, Order(Asc, Desc))
+import Database.Relational.Query.Relation (Relation, PrimeRelation, finalizeRelation, Order(Asc, Desc))
 import qualified Database.Relational.Query.Relation as Relation
 
 data Context = Context
@@ -170,10 +170,10 @@ outer =  fmap (record . fmap Relation.outer) . query Outer
 from :: Table r -> QueryJoin (Projection r)
 from =  inner . table
 
-relation :: QueryJoin (Projection r) -> Relation r
+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 st
 
-runQuery :: QueryJoin (Relation r) -> SubQuery
-runQuery = Relation.toSubQuery . fst . runQueryPrime
+-- runQuery :: QueryJoin (Relation r) -> SubQuery
+-- runQuery =  Relation.toSubQuery . fst . runQueryPrime

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

@@ -3,7 +3,7 @@
 module Database.Relational.Query.Relation (
 
   Order (..),
-  Relation,
+  PrimeRelation, Relation,
 
   outer,
   fromTable,
@@ -38,20 +38,22 @@ import qualified Language.SQL.Keyword as SQL
 
 data Order = Asc | Desc
 
-data Relation r = Table (Table r)
-                | Relation
-                  { projection  :: Projection r
-                  , product     :: Product
-                  , restriction :: Maybe (Expr Bool)
-                  , orderByRev  :: [(Order, String)]
-                  }
+data PrimeRelation a r = Table (Table r)
+                       | Relation
+                         { projection  :: Projection r
+                         , product     :: Product
+                         , restriction :: Maybe (Expr Bool)
+                         , orderByRev  :: [(Order, String)]
+                         }
 
-outer :: Relation r -> Relation (Maybe r)
+type Relation = PrimeRelation ()
+
+outer :: PrimeRelation a r -> Relation (Maybe r)
 outer =  d  where
   d (Table t)                       = Table $ Table.outer t
   d r@(Relation { projection = p }) = r { projection = Projection.outer p }
 
-width :: Relation r -> Int
+width :: PrimeRelation a r -> Int
 width =  d  where
   d (Table t)                      = Table.width t
   d (Relation { projection = p } ) = Projection.width p
@@ -77,7 +79,7 @@ composedSQL pj pd re odRev =
           orders | null odRev = []
                  | otherwise  = [ORDER, BY, orderList `SQL.sepBy` ", "]
 
-toSubQuery :: Relation r -> SubQuery
+toSubQuery :: PrimeRelation a r -> SubQuery
 toSubQuery =  d  where
   d (Table t)          = SubQuery.fromTable t
   d rel@(Relation { }) = subQuery
@@ -89,11 +91,11 @@ toSubQuery =  d  where
                          )
                          (width rel)
 
-finalizeRelation :: Projection r -> Product -> Maybe (Expr Bool) -> [(Order, String)] -> Relation r
+finalizeRelation :: Projection r -> Product -> Maybe (Expr Bool) -> [(Order, String)] -> PrimeRelation a r
 finalizeRelation =  Relation
 
-toSQL :: Relation r -> String
+toSQL :: PrimeRelation a r -> String
 toSQL =  SubQuery.toSQL . toSubQuery
 
-instance Show (Relation r) where
+instance Show (PrimeRelation a r) where
   show = show . toSubQuery

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

@@ -3,7 +3,7 @@ module Database.Relational.Query.Type (
   Query (untypeQuery), unsafeTypedQuery, fromRelation
   ) where
 
-import Database.Relational.Query.Relation (Relation)
+import Database.Relational.Query.Relation (PrimeRelation)
 import qualified Database.Relational.Query.Relation as Relation
 
 newtype Query p a = Query { untypeQuery :: String }
@@ -15,5 +15,5 @@ instance Show (Query p a) where
   show = untypeQuery
 
 
-fromRelation :: Relation r -> Query p r
+fromRelation :: PrimeRelation p r -> Query p r
 fromRelation =  unsafeTypedQuery . Relation.toSQL

schema-th/src/Database/HDBC/Schema/IBMDB2.hs

@@ -37,7 +37,7 @@ import qualified Database.Relational.Query.Table as Table
 import Database.Relational.Query.Type (unsafeTypedQuery, fromRelation)
 import Database.Relational.Query.TH (defineRecordAndTableDefault)
 import Database.Relational.Query
-  (Query, Relation, inner, relation,
+  (Query, PrimeRelation, inner, relation,
    wheres, (.=.), (!), (!?), placeholder, asc)
 
 import Language.SQL.Keyword (Keyword(..))
@@ -157,7 +157,7 @@ getType mapFromSql rec =
                       then typ
                       else [t| Maybe $(typ) |]
 
-columnsRelationFromTable :: Relation Columns
+columnsRelationFromTable :: PrimeRelation (String, String) Columns
 columnsRelationFromTable =  relation $ do
   c <- inner columns
   wheres $ c ! tabschema' .=. placeholder