diff --git a/relational-join/src/Database/Relational/Query/Monad/Restrict.hs b/relational-join/src/Database/Relational/Query/Monad/Restrict.hs index b65affe3..a966ceb4 100644 --- a/relational-join/src/Database/Relational/Query/Monad/Restrict.hs +++ b/relational-join/src/Database/Relational/Query/Monad/Restrict.hs @@ -25,7 +25,7 @@ import Database.Relational.Query.Monad.Trans.Restricting -- | Restrict only monad type used from update statement and delete statement. -type Restrict = Restrictings Identity +type Restrict = Restrictings Flat Identity -- | RestrictedStatement type synonym. -- Projection record type 'r' must be diff --git a/relational-join/src/Database/Relational/Query/Monad/Trans/Restricting.hs b/relational-join/src/Database/Relational/Query/Monad/Trans/Restricting.hs index 4739e96b..5aa0fd63 100644 --- a/relational-join/src/Database/Relational/Query/Monad/Trans/Restricting.hs +++ b/relational-join/src/Database/Relational/Query/Monad/Trans/Restricting.hs @@ -1,4 +1,5 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleInstances #-} -- | -- Module : Database.Relational.Query.Monad.Trans.Restricting @@ -34,49 +35,49 @@ import Database.Relational.Query.Monad.Class (MonadRestrict(..), MonadQuery (..) -- | 'StateT' type to accumulate join product context. -newtype Restrictings m a = - Restrictings { queryState :: StateT RestrictContext m a } +newtype Restrictings c m a = + Restrictings { queryState :: StateT (RestrictContext c) m a } deriving (MonadTrans, Monad, Functor, Applicative) -- | Run 'Restrictings' to expand context state. -runRestrictings :: Restrictings m a -- ^ RestrictContext to expand - -> RestrictContext -- ^ Initial context - -> m (a, RestrictContext) -- ^ Expanded result +runRestrictings :: Restrictings c m a -- ^ RestrictContext to expand + -> RestrictContext c -- ^ Initial context + -> m (a, RestrictContext c) -- ^ Expanded result runRestrictings = runStateT . queryState -- | Run 'Restrictings' with primary empty context to expand context state. -runRestrictingsPrime :: Restrictings m a -- ^ RestrictContext to expand - -> m (a, RestrictContext) -- ^ Expanded result +runRestrictingsPrime :: Restrictings c m a -- ^ RestrictContext to expand + -> m (a, RestrictContext c) -- ^ Expanded result runRestrictingsPrime q = runRestrictings q primeRestrictContext -- | Lift to 'Restrictings' -restrictings :: Monad m => m a -> Restrictings m a +restrictings :: Monad m => m a -> Restrictings c m a restrictings = lift -- | Unsafely update join product context. -updateRestrictContext :: Monad m => (RestrictContext -> RestrictContext) -> Restrictings m () +updateRestrictContext :: Monad m => (RestrictContext c -> RestrictContext c) -> Restrictings c m () updateRestrictContext = Restrictings . modify -- | Add whole query restriction. -updateRestriction :: Monad m => Expr Flat (Maybe Bool) -> Restrictings m () +updateRestriction :: Monad m => Expr c (Maybe Bool) -> Restrictings c m () updateRestriction e = updateRestrictContext (addRestriction e) -- | 'MonadRestrict' instance. -instance (Monad q, Functor q) => MonadRestrict (Restrictings q) where +instance (Monad q, Functor q) => MonadRestrict (Restrictings Flat q) where restrictContext = updateRestriction -- | Restricted 'MonadQuery' instance. -instance MonadQuery q => MonadQuery (Restrictings q) where +instance MonadQuery q => MonadQuery (Restrictings c q) where restrictJoin = restrictings . restrictJoin unsafeSubQuery a = restrictings . unsafeSubQuery a -- | WHERE clause prepending function. -type WherePrepend = Prepend RestrictContext +type WherePrepend = Prepend (RestrictContext Flat) -- | Run 'Restrictings' to get WHERE clause prepending function. extractWheres :: (Monad m, Functor m) - => Restrictings m a -- ^ 'Restrictings' to run - -> m (a, WherePrepend) -- ^ WHERE clause prepending function. + => Restrictings Flat m a -- ^ 'Restrictings' to run + -> m (a, WherePrepend) -- ^ WHERE clause prepending function. extractWheres r = second (liftToString composeWheres) <$> runRestrictingsPrime r -- | Run WHERE clause prepend. diff --git a/relational-join/src/Database/Relational/Query/Monad/Trans/RestrictingState.hs b/relational-join/src/Database/Relational/Query/Monad/Trans/RestrictingState.hs index e1a4a9f6..94ddae17 100644 --- a/relational-join/src/Database/Relational/Query/Monad/Trans/RestrictingState.hs +++ b/relational-join/src/Database/Relational/Query/Monad/Trans/RestrictingState.hs @@ -32,22 +32,22 @@ import qualified Language.SQL.Keyword as SQL -- | Context type for Restrict. -newtype RestrictContext = RestrictContext - { restriction' :: QueryRestriction } +newtype RestrictContext c = RestrictContext + { restriction' :: QueryRestriction c } -- | Initial 'RestrictContext'. -primeRestrictContext :: RestrictContext +primeRestrictContext :: RestrictContext c primeRestrictContext = RestrictContext Nothing -- | Add restriction of 'RestrictContext'. -addRestriction :: Expr Flat (Maybe Bool) -> RestrictContext -> RestrictContext +addRestriction :: Expr c (Maybe Bool) -> RestrictContext c -> RestrictContext c addRestriction e1 ctx = ctx { restriction' = Just . uf . restriction' $ ctx } where uf Nothing = fromJust e1 uf (Just e0) = e0 `exprAnd` fromJust e1 -- | Finalize context to extract accumulated restriction state. -restriction :: RestrictContext -> QueryRestriction +restriction :: RestrictContext c -> QueryRestriction c restriction = restriction' -- | Compose SQL String from 'RestrictContext' object. @@ -55,5 +55,5 @@ composeWheres' :: Maybe (Expr Flat Bool) -> String composeWheres' = maybe [] (\e -> unwordsSQL [WHERE, SQL.word . showExpr $ e]) -- | Compose SQL String from 'RestrictContext' object. -composeWheres :: RestrictContext -> String +composeWheres :: RestrictContext Flat -> String composeWheres = composeWheres' . restriction' diff --git a/relational-join/src/Database/Relational/Query/Monad/Type.hs b/relational-join/src/Database/Relational/Query/Monad/Type.hs index 8f402ba8..257f0353 100644 --- a/relational-join/src/Database/Relational/Query/Monad/Type.hs +++ b/relational-join/src/Database/Relational/Query/Monad/Type.hs @@ -13,10 +13,11 @@ module Database.Relational.Query.Monad.Type ( QueryCore, ) where +import Database.Relational.Query.Context (Flat) import Database.Relational.Query.Monad.Qualify (Qualify) import Database.Relational.Query.Monad.Trans.Join (QueryJoin) import Database.Relational.Query.Monad.Trans.Restricting (Restrictings) -- | Core query monad type used from simple query and aggregated query. -type QueryCore = Restrictings (QueryJoin Qualify) +type QueryCore = Restrictings Flat (QueryJoin Qualify) diff --git a/relational-join/src/Database/Relational/Query/Sub.hs b/relational-join/src/Database/Relational/Query/Sub.hs index 8cd4712b..8cdbaa98 100644 --- a/relational-join/src/Database/Relational/Query/Sub.hs +++ b/relational-join/src/Database/Relational/Query/Sub.hs @@ -50,7 +50,7 @@ import Data.Maybe (fromMaybe) import Data.Array (Array, listArray) import qualified Data.Array as Array -import Database.Relational.Query.Context (Flat, Aggregated) +import Database.Relational.Query.Context (Aggregated) import Database.Relational.Query.Expr (Expr, valueExpr) import Database.Relational.Query.Expr.Unsafe (showExpr) import Database.Relational.Query.Internal.Product @@ -293,7 +293,7 @@ queryProductSQL = ($ "") . showQueryProduct -- | Type for restriction of query. -type QueryRestriction = Maybe (Expr Flat Bool) +type QueryRestriction c = Maybe (Expr c Bool) -- | Type for group-by term