Add functions which derives queries from key constraints.

relational-join/relational-join.cabal

@@ -29,6 +29,7 @@ library
                        Database.Relational.Query.Relation
                        Database.Relational.Query.Sub
                        Database.Relational.Query.Type
+                       Database.Relational.Query.Derives
                        Database.Relational.Query.TH
   -- other-modules:
   build-depends:         base <5

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

@@ -9,7 +9,8 @@ module Database.Relational.Query (
   module Database.Relational.Query.Projection,
   module Database.Relational.Query.Relation,
   module Database.Relational.Query.Join,
-  module Database.Relational.Query.Type
+  module Database.Relational.Query.Type,
+  module Database.Relational.Query.Derives
   ) where
 
 import Database.Relational.Query.Table (Table)
@@ -27,3 +28,4 @@ import Database.Relational.Query.Projection
 import Database.Relational.Query.Relation (Relation, PrimeRelation, toSQL, fromTable)
 import Database.Relational.Query.Join
 import Database.Relational.Query.Type (Query, untypeQuery, fromRelation)
+import Database.Relational.Query.Derives

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

@@ -0,0 +1,37 @@
+{-# LANGUAGE FlexibleContexts #-}
+
+module Database.Relational.Query.Derives (
+  unique,
+
+  primary', primary
+  ) where
+
+import Database.Record (PersistableWidth)
+import Database.Relational.Query.Relation (Relation, PrimeRelation)
+import Database.Relational.Query.Expr ((.=.))
+import Database.Relational.Query.Projection (placeholder)
+import Database.Relational.Query.Join (relation, inner, wheres, (!))
+import Database.Relational.Query.Constraint
+   (Key, Primary, Unique, projectionKey,
+    HasConstraintKey(constraintKey))
+import qualified Database.Relational.Query.Constraint as Constraint
+
+unique :: PersistableWidth p
+       => Key Unique a p
+       -> Relation a
+       -> PrimeRelation p a
+unique uk rel = relation $ do
+  q <- inner rel
+  wheres $ q ! projectionKey uk .=. placeholder
+  return q
+
+primary' :: PersistableWidth p
+         => Key Primary a p
+         -> Relation a
+         -> PrimeRelation p a
+primary' pc = unique $ Constraint.uniqueKey pc
+
+primary :: (PersistableWidth p, HasConstraintKey Primary a p)
+        => Relation a
+        -> PrimeRelation p a
+primary = primary' constraintKey