mirror of
https://github.com/khibino/haskell-relational-record.git
synced 2024-12-14 22:32:07 +03:00
Apply ColumnSQL wrap type.
This commit is contained in:
parent
164338b189
commit
0795ed428a
@ -25,6 +25,7 @@ import Control.Applicative (Applicative, (<$>))
|
||||
import Control.Arrow (second, (>>>))
|
||||
|
||||
import Database.Relational.Query.Context (Flat, Aggregated)
|
||||
import Database.Relational.Query.Sub (AggregateTerm)
|
||||
import Database.Relational.Query.Monad.Trans.StatePrepend (Prepend, prepend, liftToString)
|
||||
import Database.Relational.Query.Monad.Trans.AggregatingState
|
||||
(AggregatingContext, primeAggregatingContext, addGroupBy, composeGroupBys)
|
||||
@ -71,7 +72,7 @@ updateAggregatingContext :: Monad m => (AggregatingContext -> AggregatingContext
|
||||
updateAggregatingContext = Aggregatings . modify
|
||||
|
||||
-- | Unsafely add not-typeful aggregating terms.
|
||||
addGroupBys' :: Monad m => [String] -> Aggregatings m ()
|
||||
addGroupBys' :: Monad m => [AggregateTerm] -> Aggregatings m ()
|
||||
addGroupBys' gbs = updateAggregatingContext . foldr (>>>) id $ map addGroupBy gbs
|
||||
|
||||
-- | Add restrictions for aggregated query.
|
||||
|
@ -32,11 +32,11 @@ import Control.Applicative (pure)
|
||||
import Database.Relational.Query.Context (Aggregated)
|
||||
import Database.Relational.Query.Expr (Expr, fromJust, exprAnd)
|
||||
import Database.Relational.Query.Expr.Unsafe (showExpr)
|
||||
import Database.Relational.Query.Table (sqlWordFromColumn)
|
||||
import Database.Relational.Query.Sub (AggregateTerm, AggregateTerms, AggregatedQueryRestriction)
|
||||
|
||||
import Language.SQL.Keyword (Keyword(..), unwordsSQL)
|
||||
import qualified Language.SQL.Keyword as SQL
|
||||
import qualified Language.SQL.Keyword.ConcatString as SQLs
|
||||
|
||||
|
||||
-- | Context state of aggregated query.
|
||||
@ -51,7 +51,7 @@ primeAggregatingContext :: AggregatingContext
|
||||
primeAggregatingContext = AggregatingContext DList.empty Nothing
|
||||
|
||||
-- | Add group by term into 'AggregatingContext'.
|
||||
addGroupBy :: String -> AggregatingContext -> AggregatingContext
|
||||
addGroupBy :: AggregateTerm -> AggregatingContext -> AggregatingContext
|
||||
addGroupBy t c = c { groupByTerms = groupByTerms c <> pure t }
|
||||
|
||||
-- | Add having restriction into 'AggregatingContext'.
|
||||
@ -74,6 +74,6 @@ composeGroupBys :: AggregatingContext -> String
|
||||
composeGroupBys ac = unwordsSQL $ groupBys ++ havings
|
||||
where groupBys
|
||||
| null gs = []
|
||||
| otherwise = [GROUP, BY, SQL.word . concat $ gs `SQLs.sepBy` ", "]
|
||||
gs = DList.toList (groupByTerms ac)
|
||||
| otherwise = [GROUP, BY, gs `SQL.sepBy` ", "]
|
||||
gs = map sqlWordFromColumn $ DList.toList (groupByTerms ac)
|
||||
havings = maybe [] (\e -> [HAVING, SQL.word . showExpr $ e]) $ restriction ac
|
||||
|
@ -30,14 +30,16 @@ import qualified Data.DList as DList
|
||||
import Data.Monoid ((<>))
|
||||
import Control.Applicative (pure)
|
||||
|
||||
import Database.Relational.Query.Table (ColumnSQL, sqlWordFromColumn)
|
||||
|
||||
import Language.SQL.Keyword (Keyword(..), unwordsSQL)
|
||||
import qualified Language.SQL.Keyword as SQL
|
||||
|
||||
-- | Column SQL String
|
||||
type Column = String
|
||||
type Column = ColumnSQL
|
||||
|
||||
-- | Value SQL String
|
||||
type Term = String
|
||||
type Term = ColumnSQL
|
||||
|
||||
-- | Assigning terms.
|
||||
type Assignments = DList (Column, Term)
|
||||
@ -57,5 +59,5 @@ updateAssignments col term ctx =
|
||||
-- | Concatinate order-by terms into SQL string.
|
||||
composeAssignments :: AssigningContext -> String
|
||||
composeAssignments ac = unwordsSQL $ [SET, assignList `SQL.sepBy` ", "] where
|
||||
assignList = DList.foldr (\ (col, term) r -> [SQL.word col, SQL.word term] `SQL.sepBy` " = " : r) []
|
||||
assignList = DList.foldr (\ (col, term) r -> [sqlWordFromColumn col, sqlWordFromColumn term] `SQL.sepBy` " = " : r) []
|
||||
$ assignments ac
|
||||
|
@ -29,7 +29,7 @@ import Control.Monad.Trans.State (StateT, runStateT, modify)
|
||||
import Control.Applicative (Applicative, (<$>))
|
||||
import Control.Arrow (second, (>>>))
|
||||
|
||||
import Database.Relational.Query.Sub (Order(Asc, Desc))
|
||||
import Database.Relational.Query.Sub (Order(Asc, Desc), OrderColumn)
|
||||
import Database.Relational.Query.Monad.Trans.StatePrepend (Prepend, prepend, liftToString)
|
||||
import Database.Relational.Query.Monad.Trans.OrderingState
|
||||
(OrderingContext, primeOrderingContext, updateOrderBy, composeOrderBys)
|
||||
@ -81,7 +81,7 @@ type OrderedQuery p m r = Orderings p m (Projection p r)
|
||||
|
||||
-- | Ordering term projection type interface.
|
||||
class OrderingTerms p where
|
||||
orderTerms :: p t -> [String]
|
||||
orderTerms :: p t -> [OrderColumn]
|
||||
|
||||
-- | 'Projection' is ordering term.
|
||||
instance OrderingTerms (Projection c) where
|
||||
|
@ -30,7 +30,8 @@ import qualified Data.DList as DList
|
||||
import Data.Monoid ((<>))
|
||||
import Control.Applicative (pure)
|
||||
|
||||
import Database.Relational.Query.Sub (Order, order, OrderingTerm, OrderingTerms)
|
||||
import Database.Relational.Query.Table (sqlWordFromColumn)
|
||||
import Database.Relational.Query.Sub (Order, order, OrderColumn, OrderingTerm, OrderingTerms)
|
||||
|
||||
import Language.SQL.Keyword (Keyword(..), unwordsSQL)
|
||||
import qualified Language.SQL.Keyword as SQL
|
||||
@ -47,7 +48,7 @@ primeOrderingContext :: OrderingContext
|
||||
primeOrderingContext = OrderingContext DList.empty
|
||||
|
||||
-- | Add order-by term.
|
||||
updateOrderBy :: Order -> String -> OrderingContext -> OrderingContext
|
||||
updateOrderBy :: Order -> OrderColumn -> OrderingContext -> OrderingContext
|
||||
updateOrderBy order' term ctx =
|
||||
ctx { orderBys = orderBys ctx <> pure (order', term) }
|
||||
|
||||
@ -66,7 +67,7 @@ orderingTerms = DList.toList . orderBys
|
||||
-- | Concatinate order-by terms into SQL string.
|
||||
composeOrderBys :: OrderingContext -> String
|
||||
composeOrderBys oc = unwordsSQL orders where
|
||||
orderList = DList.foldr (\ (o, e) r -> [SQL.word e, order o] `SQL.sepBy` " " : r) []
|
||||
orderList = DList.foldr (\ (o, e) r -> [sqlWordFromColumn e, order o] `SQL.sepBy` " " : r) []
|
||||
$ orderBys oc
|
||||
orders | null orderList = []
|
||||
| otherwise = [ORDER, BY, orderList `SQL.sepBy` ", "]
|
||||
|
@ -62,6 +62,7 @@ import qualified Language.SQL.Keyword.ConcatString as SQLs
|
||||
|
||||
import Database.Record (PersistableWidth, PersistableRecordWidth, derivedWidth)
|
||||
|
||||
import Database.Relational.Query.Table (columnSQL, stringFromColumnSQL)
|
||||
import Database.Relational.Query.Expr (Expr, ShowConstantSQL (showConstantSQL))
|
||||
import qualified Database.Relational.Query.Expr as Expr
|
||||
import qualified Database.Relational.Query.Expr.Unsafe as UnsafeExpr
|
||||
@ -85,7 +86,7 @@ sqlTermsString = d where
|
||||
|
||||
-- | SQL expression strings which represent projection.
|
||||
sqlStringOfProjection :: Projection c r -> String
|
||||
sqlStringOfProjection = sqlTermsString . columns
|
||||
sqlStringOfProjection = sqlTermsString . map stringFromColumnSQL . columns
|
||||
|
||||
-- | 'Expr' from 'Projection'
|
||||
exprOfProjection :: Projection c r -> Expr c r
|
||||
@ -113,7 +114,7 @@ instance ProjectablePi (Projection c) where
|
||||
|
||||
-- | Unsafely generate 'Projection' from SQL expression strings.
|
||||
unsafeSqlTermsProjection :: [String] -> Projection c t
|
||||
unsafeSqlTermsProjection = unsafeFromColumns
|
||||
unsafeSqlTermsProjection = unsafeFromColumns . map columnSQL
|
||||
|
||||
-- | Interface to project SQL terms unsafely.
|
||||
class SqlProjectable p where
|
||||
|
@ -33,7 +33,7 @@ import qualified Language.SQL.Keyword as SQL
|
||||
import Database.Record.ToSql (untypedUpdateValuesIndex)
|
||||
import Database.Relational.Query.Pi.Unsafe (Pi, unsafeExpandIndexes)
|
||||
import Database.Relational.Query.Sub (asColumnN)
|
||||
import Database.Relational.Query.Table (Table, name, columns)
|
||||
import Database.Relational.Query.Table (ColumnSQL, sqlWordFromColumn, Table, name, columns)
|
||||
import Database.Relational.Query.Projection (Projection)
|
||||
import qualified Database.Relational.Query.Projection as Projection
|
||||
|
||||
@ -43,7 +43,7 @@ selectSeedSQL :: Projection c r -> ShowS
|
||||
selectSeedSQL pj =
|
||||
(unwordsSQL [SELECT, columns' `SQL.sepBy` ", "] ++)
|
||||
where columns' = zipWith
|
||||
(\f n -> SQL.word f `asColumnN` n)
|
||||
(\f n -> sqlWordFromColumn f `asColumnN` n)
|
||||
(Projection.columns pj)
|
||||
[(0 :: Int)..]
|
||||
|
||||
@ -54,24 +54,24 @@ updateSeedSQL table = (unwordsSQL [UPDATE, SQL.word $ name table] ++)
|
||||
-- | Generate update SQL by specified key and table.
|
||||
-- Columns name list of table are also required.
|
||||
updateSQL' :: String -- ^ Table name
|
||||
-> [String] -- ^ Column name list to update
|
||||
-> [String] -- ^ Key column name list
|
||||
-> [ColumnSQL] -- ^ Column name list to update
|
||||
-> [ColumnSQL] -- ^ Key column name list
|
||||
-> String -- ^ Result SQL
|
||||
updateSQL' table cols key =
|
||||
SQL.unwordsSQL
|
||||
$ [UPDATE, SQL.word table, SET, updAssigns `SQL.sepBy` ", ",
|
||||
WHERE, keyAssigns `SQL.sepBy` " AND " ]
|
||||
where
|
||||
assigns cs = [ SQL.word c .=. "?" | c <- cs ]
|
||||
assigns cs = [ sqlWordFromColumn c .=. "?" | c <- cs ]
|
||||
updAssigns = assigns cols
|
||||
keyAssigns = assigns key
|
||||
|
||||
-- | Generate update SQL by specified key and table.
|
||||
-- Columns name list of table are also required.
|
||||
updateOtherThanKeySQL' :: String -- ^ Table name
|
||||
-> [String] -- ^ Column name list
|
||||
-> [Int] -- ^ Key column indexes
|
||||
-> String -- ^ Result SQL
|
||||
updateOtherThanKeySQL' :: String -- ^ Table name
|
||||
-> [ColumnSQL] -- ^ Column name list
|
||||
-> [Int] -- ^ Key column indexes
|
||||
-> String -- ^ Result SQL
|
||||
updateOtherThanKeySQL' table cols ixs =
|
||||
updateSQL' table updColumns keyColumns
|
||||
where
|
||||
@ -90,15 +90,15 @@ updateOtherThanKeySQL tbl key =
|
||||
updateOtherThanKeySQL' (name tbl) (columns tbl) (unsafeExpandIndexes key)
|
||||
|
||||
-- | Generate insert SQL.
|
||||
insertSQL' :: String -- ^ Table name
|
||||
-> [String] -- ^ Column name list
|
||||
-> String -- ^ Result SQL
|
||||
insertSQL' :: String -- ^ Table name
|
||||
-> [ColumnSQL] -- ^ Column name list
|
||||
-> String -- ^ Result SQL
|
||||
insertSQL' table cols =
|
||||
SQL.unwordsSQL
|
||||
$ [INSERT, INTO, SQL.word table, cols' `SQL.parenSepBy` ", ",
|
||||
VALUES, pfs `SQL.parenSepBy` ", "]
|
||||
where cols' = map SQL.word cols
|
||||
pfs = replicate (length cols) "?"
|
||||
where cols' = map sqlWordFromColumn cols
|
||||
pfs = replicate (length cols) "?"
|
||||
|
||||
-- | Generate insert SQL.
|
||||
insertSQL :: Table r -- ^ Table metadata
|
||||
|
@ -43,7 +43,7 @@ module Database.Relational.Query.Sub (
|
||||
AggregateTerm, AggregateTerms, AggregatedQueryRestriction,
|
||||
|
||||
-- * Types for ordering
|
||||
Order (..), order, OrderingTerm, OrderingTerms
|
||||
Order (..), order, OrderColumn, OrderingTerm, OrderingTerms
|
||||
) where
|
||||
|
||||
import Data.Maybe (fromMaybe)
|
||||
@ -314,8 +314,11 @@ order :: Order -> Keyword
|
||||
order Asc = ASC
|
||||
order Desc = DESC
|
||||
|
||||
-- | Type for order-by column
|
||||
type OrderColumn = ColumnSQL
|
||||
|
||||
-- | Type for order-by term
|
||||
type OrderingTerm = (Order, ColumnSQL)
|
||||
type OrderingTerm = (Order, OrderColumn)
|
||||
|
||||
-- | Type for order-by terms
|
||||
type OrderingTerms = [OrderingTerm]
|
||||
|
@ -26,18 +26,15 @@ import qualified Language.SQL.Keyword as SQL
|
||||
|
||||
|
||||
-- | Column SQL string type
|
||||
type ColumnSQL = String
|
||||
-- newtype ColumnSQL = ColumnSQL String
|
||||
newtype ColumnSQL = ColumnSQL String
|
||||
|
||||
-- | 'ColumnSQL' from string
|
||||
columnSQL :: String -> ColumnSQL
|
||||
columnSQL = id
|
||||
-- columnSQL = ColumnSQL
|
||||
columnSQL = ColumnSQL
|
||||
|
||||
-- | String from ColumnSQL
|
||||
stringFromColumnSQL :: ColumnSQL -> String
|
||||
stringFromColumnSQL = id
|
||||
-- stringFromColumnSQL (ColumnSQL s) = s
|
||||
stringFromColumnSQL (ColumnSQL s) = s
|
||||
|
||||
-- | SQL word from 'ColumnSQL'
|
||||
sqlWordFromColumn :: ColumnSQL -> SQL.Keyword
|
||||
|
Loading…
Reference in New Issue
Block a user