diff --git a/DB-record/src/Database/Record/FromSql.hs b/DB-record/src/Database/Record/FromSql.hs index 0ebb8a81..cf7af520 100644 --- a/DB-record/src/Database/Record/FromSql.hs +++ b/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 diff --git a/DB-record/src/Database/Record/Persistable.hs b/DB-record/src/Database/Record/Persistable.hs index 5b4bc091..183519d9 100644 --- a/DB-record/src/Database/Record/Persistable.hs +++ b/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 diff --git a/DB-record/src/Database/Record/ToSql.hs b/DB-record/src/Database/Record/ToSql.hs index c14888ad..7b579502 100644 --- a/DB-record/src/Database/Record/ToSql.hs +++ b/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 diff --git a/relational-join/src/Database/Relational/Query.hs b/relational-join/src/Database/Relational/Query.hs index 62eea8c2..6beb54fc 100644 --- a/relational-join/src/Database/Relational/Query.hs +++ b/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) diff --git a/relational-join/src/Database/Relational/Query/Join.hs b/relational-join/src/Database/Relational/Query/Join.hs index 1f0563d1..6208d70f 100644 --- a/relational-join/src/Database/Relational/Query/Join.hs +++ b/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 diff --git a/relational-join/src/Database/Relational/Query/Relation.hs b/relational-join/src/Database/Relational/Query/Relation.hs index ad746163..123de9b7 100644 --- a/relational-join/src/Database/Relational/Query/Relation.hs +++ b/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 diff --git a/relational-join/src/Database/Relational/Query/Type.hs b/relational-join/src/Database/Relational/Query/Type.hs index d321ca9e..b4bf249e 100644 --- a/relational-join/src/Database/Relational/Query/Type.hs +++ b/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 diff --git a/schema-th/src/Database/HDBC/Schema/IBMDB2.hs b/schema-th/src/Database/HDBC/Schema/IBMDB2.hs index 54ee38b2..a59f4145 100644 --- a/schema-th/src/Database/HDBC/Schema/IBMDB2.hs +++ b/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