Add Restrict monad transformer devided from QueryJoin.

relational-join/relational-join.cabal

@@ -31,6 +31,7 @@ library
                        Database.Relational.Query.Monad.Class
                        Database.Relational.Query.Monad.Trans.Ordering
                        Database.Relational.Query.Monad.Trans.Aggregate
+                       Database.Relational.Query.Monad.Trans.Restrict
                        Database.Relational.Query.Monad.Trans.Join
                        Database.Relational.Query.Monad.Core
                        Database.Relational.Query.Monad.Simple
@@ -51,6 +52,7 @@ library
                        Database.Relational.Query.Internal.AliasId
                        Database.Relational.Query.Internal.ShowS
                        Database.Relational.Query.Internal.Product
+                       Database.Relational.Query.Internal.RestrictContext
                        Database.Relational.Query.Internal.Context
                        Database.Relational.Query.Internal.AggregatingContext
                        Database.Relational.Query.Internal.OrderingContext

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

@@ -19,15 +19,12 @@ module Database.Relational.Query.Internal.Context (
   primeContext,
 
   updateProduct, -- takeProduct, restoreLeft,
-  addRestriction,
 
   composeSQL
   ) where
 
 import Prelude hiding (product)
 
-import Database.Relational.Query.Expr (Expr, fromTriBool, exprAnd)
-import Database.Relational.Query.Expr.Unsafe (showExpr)
 import Database.Relational.Query.Sub (asColumnN)
 
 import Database.Relational.Query.Internal.Product (QueryProductNode, QueryProduct, queryProductSQL)
@@ -42,13 +39,11 @@ import qualified Language.SQL.Keyword as SQL
 
 -- | Context type for QueryJoin.
 data Context = Context
-               { product :: Maybe QueryProductNode
-               , restriction :: Maybe (Expr Projection Bool)
-               }
+               { product :: Maybe QueryProductNode }
 
 -- | Initial 'Context'.
 primeContext :: Context
-primeContext =  Context Nothing Nothing
+primeContext =  Context Nothing
 
 -- | Update product of 'Context'.
 updateProduct' :: (Maybe QueryProductNode -> Maybe QueryProductNode) -> Context -> Context
@@ -64,28 +59,19 @@ updateProduct uf = updateProduct' (Just . uf)
 -- restoreLeft :: QueryProductNode -> Product.NodeAttr -> Context -> Context
 -- restoreLeft pL naR ctx = updateProduct (Product.growLeft pL naR) ctx
 
--- | Add restriction of 'Context'.
-addRestriction :: Expr Projection (Maybe Bool) -> Context -> Context
-addRestriction e1 ctx =
-  ctx { restriction = Just . uf . restriction $ ctx }
-  where uf  Nothing  = fromTriBool e1
-        uf (Just e0) = e0 `exprAnd` fromTriBool e1
-
 -- | Compose SQL String from QueryJoin monad object.
-composeSQL' :: Projection r -> QueryProduct -> Maybe (Expr Projection Bool) -> String
-composeSQL' pj pd re =
+composeSQL' :: Projection r -> QueryProduct -> String
+composeSQL' pj pd =
   unwordsSQL
   $ [SELECT, columns' `SQL.sepBy` ", ",
      FROM, SQL.word . queryProductSQL $ pd]
-  ++ wheres re
-    where columns' = zipWith
-                    (\f n -> SQL.word f `asColumnN` n)
-                    (Projection.columns pj)
-                    [(0 :: Int)..]
-          wheres  = Prelude.maybe [] (\e -> [WHERE, SQL.word . showExpr $ e])
+  where columns' = zipWith
+                   (\f n -> SQL.word f `asColumnN` n)
+                   (Projection.columns pj)
+                   [(0 :: Int)..]
 
 -- | Compose SQL String from QueryJoin monad object.
 composeSQL :: Projection r -> Context -> String
 composeSQL pj c = composeSQL' pj
                   (maybe (error "relation: empty product!") (Product.nodeTree) (product c))
-                  (restriction c)
+

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

@@ -0,0 +1,55 @@
+-- |
+-- Module      : Database.Relational.Query.Internal.Context
+-- Copyright   : 2013 Kei Hibino
+-- License     : BSD3
+--
+-- Maintainer  : ex8k.hibino@gmail.com
+-- Stability   : experimental
+-- Portability : unknown
+--
+-- This module provides context definition for
+-- "Database.Relational.Query.Monad.Trans.Join" and
+-- "Database.Relational.Query.Monad.Trans.Ordering".
+module Database.Relational.Query.Internal.RestrictContext (
+  -- * Context of restriction
+  RestrictContext,
+
+  primeRestrictContext,
+
+  addRestriction,
+
+  composeWheres
+  ) where
+
+import Database.Relational.Query.Expr (Expr, fromTriBool, exprAnd)
+import Database.Relational.Query.Expr.Unsafe (showExpr)
+
+import Database.Relational.Query.Projection (Projection)
+
+import Language.SQL.Keyword (Keyword(..), unwordsSQL)
+import qualified Language.SQL.Keyword as SQL
+
+
+-- | Context type for Restrict.
+data RestrictContext =
+  RestrictContext
+  { restriction :: Maybe (Expr Projection Bool) }
+
+-- | Initial 'RestrictContext'.
+primeRestrictContext :: RestrictContext
+primeRestrictContext =  RestrictContext Nothing
+
+-- | Add restriction of 'RestrictContext'.
+addRestriction :: Expr Projection (Maybe Bool) -> RestrictContext -> RestrictContext
+addRestriction e1 ctx =
+  ctx { restriction = Just . uf . restriction $ ctx }
+  where uf  Nothing  = fromTriBool e1
+        uf (Just e0) = e0 `exprAnd` fromTriBool e1
+
+-- | Compose SQL String from QueryJoin monad object.
+composeWheres' :: Maybe (Expr Projection Bool) -> String
+composeWheres' =  maybe [] (\e -> unwordsSQL [WHERE, SQL.word . showExpr $ e])
+
+-- | Compose SQL String from QueryJoin monad object.
+composeWheres :: RestrictContext -> String
+composeWheres = composeWheres' . restriction

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

@@ -32,10 +32,12 @@ import Database.Relational.Query.Sub (SubQuery, subQuery)
 
 import Database.Relational.Query.Monad.Qualify (Qualify)
 import Database.Relational.Query.Monad.Class (MonadQualify(..))
-import Database.Relational.Query.Monad.Trans.Join (QueryJoin, join')
+import Database.Relational.Query.Monad.Trans.Join (join')
 import qualified Database.Relational.Query.Monad.Trans.Join as Join
-import Database.Relational.Query.Monad.Trans.Ordering (Orderings, orderings, OrderedQuery)
+import Database.Relational.Query.Monad.Trans.Ordering (Orderings, orderings, OrderedQuery, OrderByAppend, orderByAppend)
 import qualified Database.Relational.Query.Monad.Trans.Ordering as Ordering
+import Database.Relational.Query.Monad.Trans.Restrict (restrict, WheresAppend, wheresAppend)
+import qualified Database.Relational.Query.Monad.Trans.Restrict as Restrict
 import Database.Relational.Query.Monad.Core (QueryCore)
 import Database.Relational.Query.Monad.Trans.Aggregate (Aggregatings, aggregate, appendGroupBys)
 
@@ -48,27 +50,27 @@ type AggregatedQuery r = OrderedQuery Aggregation (Aggregatings QueryCore) r
 
 -- | Lift from qualified table forms into 'QueryAggregate'.
 aggregatedQuery :: Qualify a -> QueryAggregate a
-aggregatedQuery =  orderings . aggregate . join'
+aggregatedQuery =  orderings . aggregate . restrict . join'
 
 -- | Instance to lift from qualified table forms into 'QueryAggregate'.
-instance MonadQualify Qualify (Orderings Aggregation (Aggregatings (QueryJoin Qualify))) where
+instance MonadQualify Qualify (Orderings Aggregation (Aggregatings QueryCore)) where
   liftQualify = aggregatedQuery
 
 -- | Run 'AggregatedQuery' to get SQL string.
-expandSQL :: AggregatedQuery r -> Qualify ((String, Projection r), (String -> String, String -> String))
-expandSQL q = Join.expandSQL $ assoc <$> appendGroupBys (Ordering.appendOrderBys q)  where
-  assoc ((a, b), c) = (Aggregation.unsafeProjection a, (b, c))
+expandSQL :: AggregatedQuery r -> Qualify ((String, Projection r), ((OrderByAppend, String -> String), WheresAppend))
+expandSQL q = Join.expandSQL $ assoc <$> Restrict.appendWheres (appendGroupBys (Ordering.appendOrderBys q))  where
+  assoc (((a, b), c), d) = (Aggregation.unsafeProjection a, ((b, c), d))
 
 -- | Run 'AggregatedQuery' to get SQL with 'Qualify' computation.
 toSQL :: AggregatedQuery r -- ^ 'AggregatedQuery' to run
       -> Qualify String    -- ^ Result SQL string with 'Qualify' computation
 toSQL q = do
-  ((sql, _pj), (appOrd, appGrp)) <- expandSQL q
-  return . appOrd $ appGrp sql
+  ((sql, _pj), ((appOrd, appGrp), appWhere)) <- expandSQL q
+  return . orderByAppend appOrd . appGrp . wheresAppend appWhere $ sql
 
 -- | Run 'AggregatedQuery' to get 'SubQuery' with 'Qualify' computation.
 toSubQuery :: AggregatedQuery r -- ^ 'AggregatedQuery' to run
            -> Qualify SubQuery  -- ^ Result 'SubQuery' with 'Qualify' computation
 toSubQuery q = do
-  ((sql, pj), (appOrd, appGrp)) <- expandSQL q
-  return $ subQuery (appOrd $ appGrp sql) (Projection.width pj)
+  ((sql, pj), ((appOrd, appGrp), appWhere)) <- expandSQL q
+  return $ subQuery (orderByAppend appOrd . appGrp . wheresAppend appWhere $ sql) (Projection.width pj)

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

@@ -31,8 +31,8 @@ import Database.Relational.Query.Internal.Product (NodeAttr)
 -- | Restrict context interface
 class (Functor m, Monad m) => MonadRestrict m where
   -- | Add restriction to this context.
-  restrict :: Expr Projection (Maybe Bool) -- ^ 'Expr' 'Projection' which represent restriction
-           -> m ()                         -- ^ Restricted query context
+  restrictContext :: Expr Projection (Maybe Bool) -- ^ 'Expr' 'Projection' which represent restriction
+                  -> m ()                         -- ^ Restricted query context
 
 -- | Query building interface.
 class (Functor m, Monad m) => MonadQuery m where
@@ -73,11 +73,11 @@ on =  restrictJoin . expr
 
 -- | Add restriction to this query.
 wheresE :: MonadRestrict m => Expr Projection (Maybe Bool) -> m ()
-wheresE =  restrict
+wheresE =  restrictContext
 
 -- | Add restriction to this query. Projection type version.
 wheres :: MonadRestrict m => Projection (Maybe Bool) -> m ()
-wheres =  restrict . expr
+wheres =  restrictContext . expr
 
 -- | Add /group by/ term into context and get aggregated projection.
 groupBy :: MonadAggregate m

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

@@ -15,7 +15,8 @@ module Database.Relational.Query.Monad.Core (
 
 import Database.Relational.Query.Monad.Qualify (Qualify)
 import Database.Relational.Query.Monad.Trans.Join (QueryJoin)
+import Database.Relational.Query.Monad.Trans.Restrict (Restrict)
 
 
 -- | Core query monad type used by simple query and aggregated query.
-type QueryCore = QueryJoin Qualify
+type QueryCore = Restrict (QueryJoin Qualify)

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

@@ -29,8 +29,11 @@ import Database.Relational.Query.Monad.Qualify (Qualify)
 import Database.Relational.Query.Monad.Class (MonadQualify(..))
 import Database.Relational.Query.Monad.Trans.Join (join')
 import qualified Database.Relational.Query.Monad.Trans.Join as Join
-import Database.Relational.Query.Monad.Trans.Ordering (Orderings, orderings, OrderedQuery)
+import Database.Relational.Query.Monad.Trans.Ordering
+  (Orderings, orderings, OrderedQuery, OrderByAppend, orderByAppend)
 import qualified Database.Relational.Query.Monad.Trans.Ordering as Ordering
+import Database.Relational.Query.Monad.Trans.Restrict (restrict, WheresAppend, wheresAppend)
+import qualified Database.Relational.Query.Monad.Trans.Restrict as Restrict
 import Database.Relational.Query.Monad.Core (QueryCore)
 
 import Database.Relational.Query.Sub (SubQuery, subQuery)
@@ -44,27 +47,31 @@ type SimpleQuery r = OrderedQuery Projection QueryCore r
 
 -- | Lift from qualified table forms into 'QuerySimple'.
 simple :: Qualify a -> QuerySimple a
-simple =  orderings . join'
+simple =  orderings . restrict . join'
 
 -- | Instance to lift from qualified table forms into 'QuerySimple'.
 instance MonadQualify Qualify (Orderings Projection QueryCore) where
   liftQualify = simple
 
 -- | Run 'SimpleQuery' to get SQL string.
-expandSQL :: SimpleQuery r                                      -- ^ 'SimpleQuery' to run
-          -> Qualify ((String, Projection r), String -> String) -- ^ Result SQL string and ordering appending function
-expandSQL =  Join.expandSQL . Ordering.appendOrderBys
+expandSQL' :: SimpleQuery r                                                   -- ^ 'SimpleQuery' to run
+           -> Qualify ((String, Projection r), (OrderByAppend, WheresAppend)) -- ^ Result SQL string and ordering appending function
+expandSQL' =  Join.expandSQL . fmap assoc . Restrict.appendWheres . Ordering.appendOrderBys  where
+  assoc ((a, b), c) = (a, (b, c))
+
+expandSQL :: SimpleQuery r -> Qualify (String, Projection r)
+expandSQL q = do
+  ((sql, pj), (a1, a2)) <- expandSQL' q
+  return (orderByAppend a1 (wheresAppend a2 sql), pj)
 
 -- | Run 'SimpleQuery' to get SQL string with 'Qualify' computation.
 toSQL :: SimpleQuery r  -- ^ 'SimpleQuery' to run
       -> Qualify String -- ^ Result SQL string with 'Qualify' computation
-toSQL q = do
-  ((sql, _), append) <- expandSQL q
-  return $ append sql
+toSQL q = fst `fmap` expandSQL q
 
 -- | Run 'SimpleQuery' to get 'SubQuery' with 'Qualify' computation.
 toSubQuery :: SimpleQuery r    -- ^ 'SimpleQuery' to run
            -> Qualify SubQuery -- ^ Result 'SubQuery' with 'Qualify' computation
 toSubQuery q = do
-  ((sql, pj), append) <- expandSQL q
-  return $ subQuery (append sql) (Projection.width pj)
+  (sql, pj) <- expandSQL q
+  return $ subQuery sql (Projection.width pj)

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

@@ -59,7 +59,7 @@ aggregate =  lift
 
 -- | Aggregated 'MonadRestrict'.
 instance MonadRestrict m => MonadRestrict (Aggregatings m) where
-  restrict =  aggregate . restrict
+  restrictContext =  aggregate . restrictContext
 
 -- | Aggregated 'MonadQuery'.
 instance MonadQuery m => MonadQuery (Aggregatings m) where

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

@@ -32,7 +32,7 @@ import qualified Database.Relational.Query.Projection as Projection
 import Database.Relational.Query.Expr (Expr, fromTriBool)
 import Database.Relational.Query.Sub (SubQuery, Qualified)
 
-import Database.Relational.Query.Monad.Class (MonadRestrict(..), MonadQuery (..))
+import Database.Relational.Query.Monad.Class (MonadQuery (..))
 
 
 -- | 'StateT' type to accumulate join product context.
@@ -65,10 +65,6 @@ updateJoinRestriction e = updateContext (updateProduct d)  where
   d  Nothing  = error "on: product is empty!"
   d (Just pt) = restrictProduct pt (fromTriBool e)
 
--- | Add whole query restriction.
-updateRestriction :: Monad m => Expr Projection (Maybe Bool) -> QueryJoin m ()
-updateRestriction e = updateContext (Context.addRestriction e)
-
 {-
 takeProduct :: QueryJoin (Maybe QueryProductNode)
 takeProduct =  queryCore Context.takeProduct
@@ -77,10 +73,6 @@ restoreLeft :: QueryProductNode -> NodeAttr -> QueryJoin ()
 restoreLeft pL naR = updateContext $ Context.restoreLeft pL naR
 -}
 
--- | 'MonadRestrict' instance for joinable query.
-instance (Monad q, Functor q) => MonadRestrict (QueryJoin q) where
-  restrict = updateRestriction
-
 -- | Joinable query instance.
 instance (Monad q, Functor q) => MonadQuery (QueryJoin q) where
   restrictJoin  =  updateJoinRestriction
@@ -109,7 +101,7 @@ unsafeQueryMergeWithAttr =  unsafeMergeAnother
 -}
 
 -- | Run 'QueryJoin' to get SQL string.
-expandSQL :: Monad m => QueryJoin m (Projection r, t) -> m ((String, Projection r), t)
+expandSQL :: Monad m => QueryJoin m (Projection r, st) -> m ((String, Projection r), st)
 expandSQL qp = do
   ((pj, st), c) <- runQueryPrime qp
   return ((Context.composeSQL pj c, pj), st)

relational-join/src/Database/Relational/Query/Monad/Trans/Ordering.hs

@@ -19,8 +19,9 @@ module Database.Relational.Query.Monad.Trans.Ordering (
   -- * API of query with ordering
   asc, desc,
 
-  -- * Result order by SQLs
-  appendOrderBys
+  -- * Result SQL order-by clause
+  appendOrderBys,
+  OrderByAppend (orderByAppend)
   ) where
 
 import Control.Monad.Trans.Class (MonadTrans (lift))
@@ -64,7 +65,7 @@ orderings =  lift
 
 -- | 'MonadRestrict' with ordering.
 instance MonadRestrict m => MonadRestrict (Orderings p m) where
-  restrict =  orderings . restrict
+  restrictContext =  orderings . restrictContext
 
 -- | 'MonadQuery' with ordering.
 instance MonadQuery m => MonadQuery (Orderings p m) where
@@ -143,8 +144,10 @@ appendOrderBys' c = (++ d (Context.composeOrderBys c))  where
   d "" = ""
   d s  = ' ' : s
 
+newtype OrderByAppend = OrderByAppend { orderByAppend :: String -> String }
+
 -- | Run 'Orderings' to get query result and order-by appending function.
-appendOrderBys :: MonadQuery m
-               => Orderings p m a         -- ^ 'Orderings' to run
-               -> m (a, String -> String) -- ^ Query result and order-by appending function.
-appendOrderBys q = second appendOrderBys' <$> runOrderingsPrime q
+appendOrderBys :: (Monad m, Functor m)
+               => Orderings p m a      -- ^ 'Orderings' to run
+               -> m (a, OrderByAppend) -- ^ Query result and order-by appending function.
+appendOrderBys q = second (OrderByAppend . appendOrderBys') <$> runOrderingsPrime q

relational-join/src/Database/Relational/Query/Monad/Trans/Restrict.hs

@@ -0,0 +1,90 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+-- |
+-- Module      : Database.Relational.Query.Monad.Trans.Restrict
+-- Copyright   : 2013 Kei Hibino
+-- License     : BSD3
+--
+-- Maintainer  : ex8k.hibino@gmail.com
+-- Stability   : experimental
+-- Portability : unknown
+--
+-- This module defines monad transformer which lift to basic 'MonadQuery'.
+module Database.Relational.Query.Monad.Trans.Restrict (
+  -- * Transformer into restricted context
+  Restrict, restrict,
+
+  -- * Result SQL wheres clause
+  appendWheres,
+  WheresAppend (wheresAppend)
+  ) where
+
+import Control.Monad.Trans.Class (MonadTrans (lift))
+import Control.Monad.Trans.State (modify, StateT, runStateT)
+import Control.Applicative (Applicative, (<$>))
+import Control.Arrow (second)
+
+import Database.Relational.Query.Internal.RestrictContext
+  (RestrictContext, primeRestrictContext, addRestriction)
+import qualified Database.Relational.Query.Internal.RestrictContext as RestrictContext
+import Database.Relational.Query.Projection (Projection)
+import Database.Relational.Query.Expr (Expr)
+
+import Database.Relational.Query.Monad.Class (MonadRestrict(..), MonadQuery (..))
+
+
+-- | 'StateT' type to accumulate join product context.
+newtype Restrict m a =
+  Restrict { queryState :: StateT RestrictContext m a }
+  deriving (MonadTrans, Monad, Functor, Applicative)
+
+-- | Run 'Restrict' to expand context state.
+runRestrict :: Restrict m a  -- ^ RestrictContext to expand
+             -> RestrictContext        -- ^ Initial context
+             -> m (a, RestrictContext) -- ^ Expanded result
+runRestrict =  runStateT . queryState
+
+-- | Run 'Restrict' with primary empty context to expand context state.
+runRestrictPrime :: Restrict m a           -- ^ RestrictContext to expand
+                 -> m (a, RestrictContext) -- ^ Expanded result
+runRestrictPrime q = runRestrict q primeRestrictContext
+
+-- | Lift to 'Restrict'
+restrict :: Monad m => m a -> Restrict m a
+restrict =  lift
+
+-- | Unsafely update join product context.
+updateRestrictContext :: Monad m => (RestrictContext -> RestrictContext) -> Restrict m ()
+updateRestrictContext =  Restrict . modify
+
+-- | Add whole query restriction.
+updateRestriction :: Monad m => Expr Projection (Maybe Bool) -> Restrict m ()
+updateRestriction e = updateRestrictContext (addRestriction e)
+
+-- | 'MonadRestrict' instance.
+instance (Monad q, Functor q) => MonadRestrict (Restrict q) where
+  restrictContext = updateRestriction
+
+-- | Restricted 'MonadQuery' instance.
+instance MonadQuery q => MonadQuery (Restrict q) where
+  restrictJoin     = restrict . restrictJoin
+  unsafeSubQuery a = restrict . unsafeSubQuery a
+
+-- | Get order-by appending function from 'RestrictContext'.
+appendWheres' :: RestrictContext -> String -> String
+appendWheres' c = (++ d (RestrictContext.composeWheres c))  where
+  d "" = ""
+  d s  = ' ' : s
+
+newtype WheresAppend = WheresAppend { wheresAppend :: String -> String }
+
+-- | Run 'Restricts' to get query result and order-by appending function.
+appendWheres :: (Monad m, Functor m)
+             => Restrict m a            -- ^ 'Restrict' to run
+             -> m (a,  WheresAppend) -- ^ Query result and order-by appending function.
+appendWheres r = second (WheresAppend . appendWheres') <$> runRestrictPrime r
+
+-- expandSQL :: Monad m => Restrict m a -> m (String, a)
+-- expandSQL r = do
+--   (a, c) <- runRestrictPrime r
+--   return (RestrictContext.composeSQL c, a)