diff --git a/relational-join/src/Database/Relational/Query/Expr.hs b/relational-join/src/Database/Relational/Query/Expr.hs index 72e8500e..299f2886 100644 --- a/relational-join/src/Database/Relational/Query/Expr.hs +++ b/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) ++ [')'] diff --git a/relational-join/src/Database/Relational/Query/Internal/AggregatingContext.hs b/relational-join/src/Database/Relational/Query/Internal/AggregatingContext.hs index 97171f2a..bdc9ffcc 100644 --- a/relational-join/src/Database/Relational/Query/Internal/AggregatingContext.hs +++ 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 qualified Database.Relational.Query.Projectable as Projectable +import Database.Relational.Query.Expr (Expr, showExpr, fromTriBool, exprAnd) 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 - uf (Just e0) = e0 `Projectable.and` e1 + where uf Nothing = fromTriBool e1 + uf (Just e0) = e0 `exprAnd` fromTriBool e1 composeGroupBys :: AggregatingContext -> String composeGroupBys ac = unwords [unwordsSQL groupBys, unwordsSQL havings] diff --git a/relational-join/src/Database/Relational/Query/Internal/Context.hs b/relational-join/src/Database/Relational/Query/Internal/Context.hs index e17bef64..a04ffe75 100644 --- a/relational-join/src/Database/Relational/Query/Internal/Context.hs +++ b/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 - uf (Just e0) = e0 `Projectable.and` e1 + where uf Nothing = fromTriBool e1 + uf (Just e0) = e0 `exprAnd` fromTriBool e1 composeSQL' :: Projection r -> QueryProduct -> Maybe (Expr Bool) -> String composeSQL' pj pd re = diff --git a/relational-join/src/Database/Relational/Query/Internal/Product.hs b/relational-join/src/Database/Relational/Query/Internal/Product.hs index 3d88656e..62046189 100644 --- a/relational-join/src/Database/Relational/Query/Internal/Product.hs +++ b/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.Projectable (valueTrue, and) +import Database.Relational.Query.Expr (Expr, showExpr, fromTriBool, exprAnd) +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 diff --git a/relational-join/src/Database/Relational/Query/Monad/Aggregate.hs b/relational-join/src/Database/Relational/Query/Monad/Aggregate.hs index 7c35621f..3247c580 100644 --- a/relational-join/src/Database/Relational/Query/Monad/Aggregate.hs +++ b/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 diff --git a/relational-join/src/Database/Relational/Query/Monad/Class.hs b/relational-join/src/Database/Relational/Query/Monad/Class.hs index dc3b1ea8..1a426a56 100644 --- a/relational-join/src/Database/Relational/Query/Monad/Class.hs +++ b/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 () - wheres :: Expr Bool -> m () + on :: Expr (Maybe 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 () diff --git a/relational-join/src/Database/Relational/Query/Monad/Core.hs b/relational-join/src/Database/Relational/Query/Monad/Core.hs index c6b65fd4..20deda74 100644 --- a/relational-join/src/Database/Relational/Query/Monad/Core.hs +++ b/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) diff --git a/relational-join/src/Database/Relational/Query/Projectable.hs b/relational-join/src/Database/Relational/Query/Projectable.hs index a939c86b..04d6fd41 100644 --- a/relational-join/src/Database/Relational/Query/Projectable.hs +++ b/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 = value True +valueTrue :: (SqlProjectable p, ProjectableMaybe p) => p (Maybe Bool) +valueTrue = just $ value True -valueFalse :: SqlProjectable p => p Bool -valueFalse = value False +valueFalse :: (SqlProjectable p, ProjectableMaybe p) => p (Maybe Bool) +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 diff --git a/relational-join/src/Database/Relational/Schema/PostgreSQL.hs b/relational-join/src/Database/Relational/Schema/PostgreSQL.hs index cc21ca1d..abb8be6e 100644 --- a/relational-join/src/Database/Relational/Schema/PostgreSQL.hs +++ b/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)