Add a type alias UExpr, Expr for Singleton value.

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

@@ -15,6 +15,7 @@ import Database.Relational.Query.Pi
 import Database.Relational.Query.AliasId (Qualified)
 import Database.Relational.Query.Expr
 import Database.Relational.Query.Sub (SubQuery, unitSQL, width, queryWidth)
-import Database.Relational.Query.Projection (Projectable((!)), ProjectableMaybe((!?)))
+import Database.Relational.Query.Projection
+  (Projectable((!)), ProjectableMaybe((!?)), ValueProjectable(value))
 import Database.Relational.Query.Relation (Relation)
 import Database.Relational.Query.Join

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

@@ -5,10 +5,11 @@ module Database.Relational.Query.Expr (
 
   ShowConstantSQL (showConstantSQL),
 
-  valueExpr, just, unsafeFromJust, valueExpr',
-  exprTrue, exprNull,
+  UExpr, valueExpr,
 
-  (.=.), (.<>.), (.>.), (.<.), and, or,
+  just, unsafeFromJust,
+
+  (.=.), (.<>.), (.>.), (.<.), and, or
   ) where
 
 import Prelude hiding (and, or)
@@ -20,7 +21,7 @@ import qualified Data.Text as T
 
 import qualified Language.SQL.Keyword as SQL
 
-import Database.Relational.Query.Expr.Unsafe (Expr(Expr, showExpr), compareBinOp)
+import Database.Relational.Query.Expr.Unsafe (Expr(Expr, showExpr), UExpr, compareBinOp)
 
 
 intExprSQL :: (Show a, Integral a) => a -> String
@@ -56,8 +57,18 @@ instance ShowConstantSQL ByteString where
 instance ShowConstantSQL Text where
   showConstantSQL = stringExprSQL . T.unpack
 
+instance ShowConstantSQL Bool where
+  showConstantSQL = d  where
+    d True  = "(0=0)"
+    d False = "(0=1)"
 
-valueExpr :: ShowConstantSQL ft => ft -> Expr ft
+instance ShowConstantSQL a => ShowConstantSQL (Maybe a) where
+  showConstantSQL = d  where
+    d (Just a)  = showConstantSQL a
+    d (Nothing) = "NULL"
+
+
+valueExpr :: ShowConstantSQL ft => ft -> UExpr ft
 valueExpr =  Expr . showConstantSQL
 
 just :: Expr ft -> Expr (Maybe ft)
@@ -67,32 +78,22 @@ unsafeFromJust :: Expr (Maybe ft) -> Expr ft
 unsafeFromJust =  Expr . showExpr
 
 
-valueExpr' :: ShowConstantSQL ft => ft -> Expr (Maybe ft)
-valueExpr' =  just . valueExpr
-
-exprTrue :: Expr Bool
-exprTrue =  Expr "(0=0)"
-
-exprNull :: Expr (Maybe a)
-exprNull =  Expr "NULL"
-
-
-(.=.) :: Expr ft -> Expr ft -> Expr Bool
+(.=.) :: Expr ft -> Expr ft -> UExpr Bool
 (.=.) =  compareBinOp (SQL..=.)
 
-(.<>.) :: Expr ft -> Expr ft -> Expr Bool
+(.<>.) :: Expr ft -> Expr ft -> UExpr Bool
 (.<>.) =  compareBinOp (SQL..<>.)
 
-(.>.) :: Expr ft -> Expr ft -> Expr Bool
+(.>.) :: Expr ft -> Expr ft -> UExpr Bool
 (.>.) =  compareBinOp (SQL.defineBinOp (SQL.word ">"))
 
-(.<.) :: Expr ft -> Expr ft -> Expr Bool
+(.<.) :: Expr ft -> Expr ft -> UExpr Bool
 (.<.) =  compareBinOp (SQL.defineBinOp (SQL.word "<"))
 
-and :: Expr Bool ->  Expr Bool ->  Expr Bool
+and :: UExpr Bool ->  UExpr Bool ->  UExpr Bool
 and =  compareBinOp SQL.and
 
-or :: Expr Bool ->  Expr Bool ->  Expr Bool
+or :: UExpr Bool ->  UExpr Bool ->  UExpr Bool
 or =  compareBinOp SQL.or
 
 infixr 4 .=., .<>.

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

@@ -2,11 +2,13 @@
 module Database.Relational.Query.Expr.Unsafe (
   Expr(Expr, showExpr),
 
-  compareBinOp, binOp
+  UExpr, compareBinOp, binOp
   ) where
 
 import qualified Language.SQL.Keyword as SQL
 
+import Database.Record.Persistable (Singleton)
+
 newtype Expr a = Expr { showExpr :: String }
 
 instance Show (Expr a) where
@@ -21,6 +23,8 @@ binOp op a b = Expr . paren . SQL.wordShow
                $ op (wordExpr a) (wordExpr b)
   where wordExpr = SQL.word . showExpr
 
+type UExpr a = Expr (Singleton a)
+
 compareBinOp :: (SQL.Keyword -> SQL.Keyword -> SQL.Keyword)
-             -> Expr ft -> Expr ft -> Expr Bool
+             -> Expr ft -> Expr ft -> UExpr Bool
 compareBinOp =  binOp

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

@@ -23,7 +23,7 @@ import qualified Database.Relational.Query.AliasId as AliasId
 import Database.Relational.Query.Table (Table)
 import Database.Relational.Query.Sub (SubQuery)
 
-import Database.Relational.Query.Expr (Expr)
+import Database.Relational.Query.Expr (Expr, UExpr)
 import qualified Database.Relational.Query.Expr as Expr
 
 import Database.Relational.Query.Product
@@ -39,7 +39,7 @@ import qualified Database.Relational.Query.Relation as Relation
 data Context = Context
                { currentAliasId :: AliasId
                , product :: Maybe QueryProduct
-               , restriction :: Maybe (Expr Bool)
+               , restriction :: Maybe (UExpr Bool)
                }
 
 primContext :: Context
@@ -52,7 +52,7 @@ updateProduct' :: (Maybe QueryProduct -> QueryProduct) -> Context -> Context
 updateProduct' uf ctx =
   ctx { product = Just . uf . product $ ctx }
 
-updateRestriction' :: Expr Bool -> Context -> Context
+updateRestriction' :: UExpr Bool -> Context -> Context
 updateRestriction' e1 ctx =
   ctx { restriction = Just . uf . restriction $ ctx }
   where uf  Nothing = e1
@@ -77,19 +77,19 @@ updateContext uf =
 updateProduct :: JoinAttr -> Qualified (Relation r) -> QueryJoin ()
 updateProduct attr qrel = updateContext (updateProduct' (`growProduct` (attr, fmap Relation.toSubQuery qrel)))
 
-updateJoinRestriction :: Expr Bool -> QueryJoin ()
+updateJoinRestriction :: UExpr Bool -> QueryJoin ()
 updateJoinRestriction e = updateContext (updateProduct' d)  where
   d  Nothing  = error "addProductRestriction: product is empty!"
   d (Just pt) = restrictProduct pt e
 
-updateRestriction :: Expr Bool -> QueryJoin ()
+updateRestriction :: UExpr Bool -> QueryJoin ()
 updateRestriction e = updateContext (updateRestriction' e)
 
 
-on :: Expr Bool -> QueryJoin ()
+on :: UExpr Bool -> QueryJoin ()
 on =  updateJoinRestriction
 
-wheres :: Expr Bool -> QueryJoin ()
+wheres :: UExpr Bool -> QueryJoin ()
 wheres =  updateRestriction
 
 

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

@@ -7,7 +7,8 @@ module Database.Relational.Query.Product (
   ) where
 
 import Prelude hiding (and)
-import Database.Relational.Query.Expr (Expr, exprTrue, showExpr, and)
+import Database.Relational.Query.Expr (UExpr, showExpr, and)
+import Database.Relational.Query.Projection (valueTrue)
 import Database.Relational.Query.AliasId (Qualified)
 import Database.Relational.Query.Sub (SubQuery)
 import qualified Database.Relational.Query.Sub as SubQuery
@@ -23,7 +24,7 @@ import Data.Foldable (Foldable (foldMap))
 data JoinAttr = Inner | Outer
 
 data ProductTree q = Leaf JoinAttr q
-                   | Join JoinAttr !(ProductTree q) !(ProductTree q) !(Maybe (Expr Bool))
+                   | Join JoinAttr !(ProductTree q) !(ProductTree q) !(Maybe (UExpr Bool))
 
 joinAttr :: ProductTree q -> JoinAttr
 joinAttr =  d  where
@@ -43,7 +44,7 @@ growProduct =  d  where
   d Nothing  (ja, q) = Leaf ja q
   d (Just t) (ja, q) = Join Inner t (Leaf ja q) Nothing
 
-restrictProduct :: ProductTree q -> Expr Bool -> ProductTree q
+restrictProduct :: ProductTree q -> UExpr Bool -> ProductTree q
 restrictProduct =  d  where
   d (Join ja lp rp Nothing)   rs' = Join ja lp rp (Just rs')
   d (Join ja lp rp (Just rs)) rs' = Join ja lp rp (Just $ rs `and` rs')
@@ -86,7 +87,7 @@ showQueryProduct =  rec  where
      showWordsSQL [joinType (joinAttr left') (joinAttr right'), JOIN],
      urec right',
      showWordSQL ON,
-     showString . showExpr . fromMaybe exprTrue $ rs]
+     showString . showExpr . fromMaybe valueTrue $ rs]
 
 productSQL :: Product -> String
 productSQL =  d  where

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

@@ -9,7 +9,12 @@ module Database.Relational.Query.Projection (
 
   toExpr,
 
-  Projectable ((!)), ProjectableMaybe ((!?))
+  Projectable ((!)), ProjectableMaybe ((!?)),
+
+  valueProjection,
+  ValueProjectable (value),
+
+  valueTrue, valueFalse, valueNull
   ) where
 
 import Prelude hiding ((!!))
@@ -20,11 +25,11 @@ import Data.List (intercalate)
 
 import Database.Record.Persistable
   (PersistableRecordWidth, runPersistableRecordWidth,
-   PersistableWidth, persistableWidth)
+   PersistableWidth, persistableWidth, Singleton)
 
 import Database.Relational.Query.Pi (Pi)
 import qualified Database.Relational.Query.Pi as Pi
-import Database.Relational.Query.Expr (Expr)
+import Database.Relational.Query.Expr (Expr, valueExpr, ShowConstantSQL (showConstantSQL))
 import qualified Database.Relational.Query.Expr.Unsafe as UnsafeExpr
 import Database.Relational.Query.AliasId (Qualified)
 import Database.Relational.Query.Sub (SubQuery, queryWidth)
@@ -119,3 +124,26 @@ instance ProjectableMaybe Projection where
 
 instance ProjectableMaybe Expr where
   p !? pi' = toExpr $ p `projectMaybe` pi'
+
+
+valueProjection :: ShowConstantSQL t => t -> Projection (Singleton t)
+valueProjection =  unsafeFromColumns . (:[]) . showConstantSQL
+
+class ValueProjectable p where
+  value :: (ShowConstantSQL t) => t -> p (Singleton t)
+
+instance ValueProjectable Projection where
+  value = valueProjection
+
+instance ValueProjectable Expr where
+  value = valueExpr
+
+
+valueTrue :: ValueProjectable p => p (Singleton Bool)
+valueTrue =  value True
+
+valueFalse :: ValueProjectable p => p (Singleton Bool)
+valueFalse =  value False
+
+valueNull :: (ValueProjectable p, ShowConstantSQL a) => p (Singleton (Maybe a))
+valueNull =  value Nothing

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

@@ -15,7 +15,7 @@ import Prelude hiding (product, and)
 
 import Database.Relational.Query.AliasId (asColumnN)
 
-import Database.Relational.Query.Expr (Expr, showExpr)
+import Database.Relational.Query.Expr (UExpr, showExpr)
 
 import Database.Relational.Query.Table (Table)
 import qualified Database.Relational.Query.Table as Table
@@ -36,7 +36,7 @@ data Relation r = Table (Table r)
                 | Relation
                   { projection  :: Projection r
                   , product     :: Product
-                  , restriction :: Maybe (Expr Bool)
+                  , restriction :: Maybe (UExpr Bool)
                   }
 
 outer :: Relation r -> Relation (Maybe r)
@@ -52,7 +52,7 @@ width =  d  where
 fromTable :: Table r -> Relation r
 fromTable =  Table
 
-composedSQL :: Projection r -> Product -> Maybe (Expr Bool) -> String
+composedSQL :: Projection r -> Product -> Maybe (UExpr Bool) -> String
 composedSQL pj pd re =
   unwordsSQL
   $ [SELECT, columns' `SQL.sepBy` SQL.word ", ",
@@ -74,7 +74,7 @@ toSubQuery =  d  where
                           (restriction rel))
                          (width rel)
 
-finalizeRelation :: Projection r -> Product -> Maybe (Expr Bool) -> Relation r
+finalizeRelation :: Projection r -> Product -> Maybe (UExpr Bool) -> Relation r
 finalizeRelation =  Relation
 
 instance Show (Relation r) where