Change boolean result operators type.

For nullable comparison result and tri-state bool cases.

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

@@ -7,7 +7,9 @@ module Database.Relational.Query.Expr (
 
   valueExpr,
 
-  just, flattenMaybe
+  just, flattenMaybe,
+
+  fromTriBool, exprAnd
   ) where
 
 import Prelude hiding (and, or)
@@ -19,6 +21,9 @@ import qualified Data.Text as T
 
 import Database.Relational.Query.Expr.Unsafe (Expr(Expr), showExpr)
 
+import qualified Language.SQL.Keyword as SQL
+import qualified Language.SQL.Keyword.ConcatString as SQLs
+
 
 intExprSQL :: (Show a, Integral a) => a -> String
 intExprSQL =  show
@@ -70,8 +75,17 @@ instance ShowConstantSQL a => ShowConstantSQL (Maybe a) where
 valueExpr :: ShowConstantSQL ft => ft -> Expr ft
 valueExpr =  Expr . showConstantSQL
 
+unsafeCastExpr :: Expr a -> Expr b
+unsafeCastExpr =  Expr . showExpr
+
 just :: Expr ft -> Expr (Maybe ft)
-just =  Expr . showExpr
+just =  unsafeCastExpr
 
 flattenMaybe :: Expr (Maybe (Maybe ft)) -> Expr (Maybe ft)
-flattenMaybe =  Expr . showExpr
+flattenMaybe =  unsafeCastExpr
+
+fromTriBool :: Expr (Maybe Bool) -> Expr Bool
+fromTriBool =  unsafeCastExpr
+
+exprAnd :: Expr Bool -> Expr Bool -> Expr Bool
+exprAnd a b = Expr $ '(' : SQLs.defineBinOp SQL.AND (showExpr a) (showExpr b) ++ [')']

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

@@ -15,8 +15,7 @@ import qualified Data.DList as DList
 import Data.Monoid ((<>))
 import Control.Applicative (pure)
 
-import Database.Relational.Query.Expr (Expr, showExpr)
+import Database.Relational.Query.Expr (Expr, showExpr, fromTriBool, exprAnd)
-import qualified Database.Relational.Query.Projectable as Projectable
 
 import Language.SQL.Keyword (Keyword(..), unwordsSQL)
 import qualified Language.SQL.Keyword as SQL
@@ -37,11 +36,11 @@ primeAggregatingContext =  AggregatingContext DList.empty Nothing
 addGroupBy :: String -> AggregatingContext -> AggregatingContext
 addGroupBy t c =  c { groupByTerms = groupByTerms c <> pure t }
 
-addRestriction :: Expr Bool -> AggregatingContext -> AggregatingContext
+addRestriction :: Expr (Maybe Bool) -> AggregatingContext -> AggregatingContext
 addRestriction e1 ctx =
   ctx { restriction = Just . uf . restriction $ ctx }
-  where uf  Nothing = e1
+  where uf  Nothing  = fromTriBool e1
-        uf (Just e0) = e0 `Projectable.and` e1
+        uf (Just e0) = e0 `exprAnd` fromTriBool e1
 
 composeGroupBys :: AggregatingContext -> String
 composeGroupBys ac = unwords [unwordsSQL groupBys, unwordsSQL havings]

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

@@ -29,14 +29,13 @@ import Control.Applicative (pure)
 
 import Database.Relational.Query.Internal.AliasId (primAlias, AliasId, newAliasId, asColumnN)
 
-import Database.Relational.Query.Expr (Expr, showExpr)
+import Database.Relational.Query.Expr (Expr, showExpr, fromTriBool, exprAnd)
 
 import Database.Relational.Query.Internal.Product (QueryProductNode, QueryProduct, queryProductSQL)
 import qualified Database.Relational.Query.Internal.Product as Product
 
 import Database.Relational.Query.Projection (Projection)
 import qualified Database.Relational.Query.Projection as Projection
-import qualified Database.Relational.Query.Projectable as Projectable
 
 import Language.SQL.Keyword (Keyword(..), unwordsSQL)
 import qualified Language.SQL.Keyword as SQL
@@ -69,11 +68,11 @@ takeProduct ctx = (product ctx, updateProduct' (const Nothing) ctx)
 restoreLeft :: QueryProductNode -> Product.NodeAttr -> Context -> Context
 restoreLeft pL naR ctx = updateProduct (Product.growLeft pL naR) ctx
 
-addRestriction :: Expr Bool -> Context -> Context
+addRestriction :: Expr (Maybe Bool) -> Context -> Context
 addRestriction e1 ctx =
   ctx { restriction = Just . uf . restriction $ ctx }
-  where uf  Nothing = e1
+  where uf  Nothing  = fromTriBool e1
-        uf (Just e0) = e0 `Projectable.and` e1
+        uf (Just e0) = e0 `exprAnd` fromTriBool e1
 
 composeSQL' :: Projection r -> QueryProduct -> Maybe (Expr Bool) -> String
 composeSQL' pj pd re =

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

@@ -7,8 +7,8 @@ module Database.Relational.Query.Internal.Product (
   ) where
 
 import Prelude hiding (and, product)
-import Database.Relational.Query.Expr (Expr, showExpr)
+import Database.Relational.Query.Expr (Expr, showExpr, fromTriBool, exprAnd)
-import Database.Relational.Query.Projectable (valueTrue, and)
+import Database.Relational.Query.Projectable (valueTrue)
 import Database.Relational.Query.AliasId (Qualified)
 import Database.Relational.Query.Sub (SubQuery)
 import qualified Database.Relational.Query.Sub as SubQuery
@@ -67,7 +67,7 @@ product =  Join
 restrictProduct' :: ProductTree q -> Expr Bool -> ProductTree q
 restrictProduct' =  d  where
   d (Join lp rp Nothing)   rs' = Join lp rp (Just rs')
-  d (Join lp rp (Just rs)) rs' = Join lp rp (Just $ rs `and` rs')
+  d (Join lp rp (Just rs)) rs' = Join lp rp (Just $ rs `exprAnd` rs')
   d leaf'@(Leaf _)         _   = leaf' -- or error on compile
 
 restrictProduct :: Node q -> Expr Bool -> Node q
@@ -89,7 +89,8 @@ showQueryProduct =  rec  where
      showWordsSQL [joinType (nodeAttr left') (nodeAttr right'), JOIN],
      urec right',
      showWordSQL ON,
-     showString . showExpr . fromMaybe valueTrue {- or error on compile -}  $ rs]
+     showString . showExpr
+     . fromMaybe (fromTriBool valueTrue) {- or error on compile -}  $ rs]
 
 queryProductSQL :: QueryProduct -> String
 queryProductSQL =  ($ "") . showQueryProduct

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

@@ -75,7 +75,7 @@ updateAggregatingContext =  Aggregatings . modify
 addGroupBys' :: Monad m => [String] -> Aggregatings m ()
 addGroupBys' gbs = updateAggregatingContext (\c -> foldl (flip Context.addGroupBy) c gbs)
 
-addRestriction' :: Monad m => Expr Bool -> Aggregatings m ()
+addRestriction' :: Monad m => Expr (Maybe Bool) -> Aggregatings m ()
 addRestriction' =  updateAggregatingContext . Context.addRestriction
 
 addGroupBys :: MonadQuery m => Projection r -> Aggregatings m (Aggregation r)
@@ -83,7 +83,7 @@ addGroupBys p = do
   addGroupBys' . Projection.columns $ p
   return $ Aggregation.unsafeFromProjection p
 
-addRestriction :: MonadQuery m => Aggregation Bool -> Aggregatings m ()
+addRestriction :: MonadQuery m => Aggregation (Maybe Bool) -> Aggregatings m ()
 addRestriction =  addRestriction' . projectAggregation
 
 instance MonadQuery m => MonadAggregate (Aggregatings m) where

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

@@ -9,9 +9,9 @@ import Database.Relational.Query.Projection (Projection)
 import Database.Relational.Query.Aggregation (Aggregation)
 
 class UnsafeMonadQuery m => MonadQuery m where
-  on     :: Expr Bool -> m ()
+  on     :: Expr (Maybe Bool) -> m ()
-  wheres :: Expr Bool -> m ()
+  wheres :: Expr (Maybe Bool) -> m ()
 
 class MonadQuery m => MonadAggregate m where
   groupBy :: Projection r -> m (Aggregation r)
-  having  :: Aggregation Bool -> m ()
+  having  :: Aggregation (Maybe Bool) -> m ()

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

@@ -23,7 +23,7 @@ import qualified Database.Relational.Query.Internal.Context as Context
 import Database.Relational.Query.Internal.AliasId (AliasId, Qualified)
 import qualified Database.Relational.Query.Internal.AliasId as AliasId
 
-import Database.Relational.Query.Expr (Expr)
+import Database.Relational.Query.Expr (Expr, fromTriBool)
 
 import Database.Relational.Query.Internal.Product
   (NodeAttr, QueryProductNode, growProduct, restrictProduct)
@@ -57,12 +57,12 @@ updateContext :: (Context -> Context) -> QueryCore ()
 updateContext =  QueryCore . modify
 
 
-updateJoinRestriction :: Expr Bool -> QueryCore ()
+updateJoinRestriction :: Expr (Maybe Bool) -> QueryCore ()
 updateJoinRestriction e = updateContext (updateProduct d)  where
   d  Nothing  = error "on: product is empty!"
-  d (Just pt) = restrictProduct pt e
+  d (Just pt) = restrictProduct pt (fromTriBool e)
 
-updateRestriction :: Expr Bool -> QueryCore ()
+updateRestriction :: Expr (Maybe Bool) -> QueryCore ()
 updateRestriction e = updateContext (Context.addRestriction e)
 
 takeProduct :: QueryCore (Maybe QueryProductNode)

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

@@ -93,11 +93,11 @@ placeholder =  unsafeProjectSql "?"
 value :: (ShowConstantSQL t, SqlProjectable p) => t -> p t
 value =  unsafeProjectSql . showConstantSQL
 
-valueTrue :: SqlProjectable p => p Bool
+valueTrue  :: (SqlProjectable p, ProjectableMaybe p) => p (Maybe Bool)
-valueTrue =  value True
+valueTrue  =  just $ value True
 
-valueFalse :: SqlProjectable p => p Bool
+valueFalse :: (SqlProjectable p, ProjectableMaybe p) => p (Maybe Bool)
-valueFalse =  value False
+valueFalse =  just $ value False
 
 values :: (Projectable p, ShowConstantSQL t) => [t] -> p [t]
 values =  project . unsafeFromColumns . map showConstantSQL
@@ -147,7 +147,7 @@ every =  unsafeAggregateOp SQL.EVERY
 any'  =  unsafeAggregateOp SQL.ANY
 some' =  unsafeAggregateOp SQL.SOME
 
-every, any', some' :: Projection Bool -> Aggregation Bool
+every, any', some' :: Projection (Maybe Bool) -> Aggregation (Maybe Bool)
 
 
 type SqlBinOp = String -> String -> String
@@ -163,7 +163,7 @@ unsafeBinOp op a b = unsafeProjectSql . paren
 
 compareBinOp :: (SqlProjectable p, ProjectableShowSql p)
              => SqlBinOp
-             -> p a -> p a -> p Bool
+             -> p a -> p a -> p (Maybe Bool)
 compareBinOp =  unsafeBinOp
 
 numBinOp :: (SqlProjectable p, ProjectableShowSql p, Num a)
@@ -179,14 +179,14 @@ numBinOp =  unsafeBinOp
 
 (.=.), (.<>.), (.>.), (.<.)
   :: (SqlProjectable p, ProjectableShowSql p)
-  => p ft -> p ft -> p Bool
+  => p ft -> p ft -> p (Maybe Bool)
 
 and = compareBinOp SQLs.and
 or  = compareBinOp SQLs.or
 
 and, or
   :: (SqlProjectable p, ProjectableShowSql p)
-  => p Bool ->  p Bool ->  p Bool
+  => p (Maybe Bool) ->  p (Maybe Bool) ->  p (Maybe Bool)
 
 numBinOp' :: (SqlProjectable p, ProjectableShowSql p, Num a)
           => String -> p a -> p a -> p a
@@ -202,11 +202,11 @@ numBinOp' = numBinOp . sqlBinOp
   => p a -> p a -> p a
 
 in' :: (SqlProjectable p, ProjectableShowSql p)
-    => p t -> p [t] -> p Bool
+    => p t -> p [t] -> p (Maybe Bool)
 in' =  unsafeBinOp (SQLs.in')
 
 isNull :: (SqlProjectable p, ProjectableShowSql p)
-       => p (Maybe t) -> p Bool
+       => p (Maybe t) -> p (Maybe Bool)
 isNull x = compareBinOp (SQLs.defineBinOp SQL.IS) x valueNull
 
 

relational-join/src/Database/Relational/Schema/PostgreSQL.hs

@@ -25,7 +25,7 @@ import Database.Record.Instances ()
 import Database.Relational.Query.Type (fromRelation)
 import Database.Relational.Query
   (Query, PrimeRelation, query, relation, query', relation', expr,
-   wheres, (.=.), (.>.), in', values, (!),
+   wheres, (.=.), (.>.), in', values, (!), just,
    placeholder, asc, value, unsafeProjectSql, (><))
 
 import Database.Relational.Schema.PgCatalog.PgNamespace (pgNamespace)
@@ -145,7 +145,7 @@ primaryKeyRelation = relation' $ do
 
   wheres $ con ! Constraint.conrelid' .=. att ! Attr.attrelid'
   wheres $ unsafeProjectSql "conkey[1]" .=. att ! Attr.attnum'
-  wheres $ att ! Attr.attnotnull'
+  wheres $ just (att ! Attr.attnotnull')
   wheres $ con ! Constraint.contype'  .=. value 'p'  -- 'p': primary key constraint type
   wheres $ unsafeProjectSql "array_length (conkey, 1)" .=. value (1 :: Int32)