diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2013, Kei Hibino + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Kei Hibino nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/relational-query.cabal b/relational-query.cabal new file mode 100644 --- /dev/null +++ b/relational-query.cabal @@ -0,0 +1,107 @@ +name: relational-query +version: 0.0.1.0 +synopsis: Typeful, Modular, Relational, algebraic query engine +description: This package contiains typeful relation structure and + relational-algebraic query building DSL which can + translate into SQL query. + Supported query features are below: + - Type safe query building + - Restriction, Join, Aggregation + - Modularized relations + - Typed placeholders +homepage: http://twitter.com/khibino +license: BSD3 +license-file: LICENSE +author: Kei Hibino +maintainer: ex8k.hibino@gmail.com +copyright: Copyright (c) 2013 Kei Hibino +category: Database +build-type: Simple +cabal-version: >=1.10 + +library + exposed-modules: + Database.Relational.Query + Database.Relational.Query.Table + Database.Relational.Query.SQL + Database.Relational.Query.Pure + Database.Relational.Query.Pi + Database.Relational.Query.Pi.Unsafe + Database.Relational.Query.Constraint + Database.Relational.Query.Context + Database.Relational.Query.Projectable + Database.Relational.Query.ProjectableExtended + Database.Relational.Query.Expr + Database.Relational.Query.Expr.Unsafe + Database.Relational.Query.Component + Database.Relational.Query.Sub + Database.Relational.Query.Projection + Database.Relational.Query.Monad.Class + Database.Relational.Query.Monad.Trans.Ordering + Database.Relational.Query.Monad.Trans.Aggregating + Database.Relational.Query.Monad.Trans.Restricting + Database.Relational.Query.Monad.Trans.Join + Database.Relational.Query.Monad.Trans.Config + Database.Relational.Query.Monad.Trans.Assigning + Database.Relational.Query.Monad.Type + Database.Relational.Query.Monad.Simple + Database.Relational.Query.Monad.Aggregate + Database.Relational.Query.Monad.Unique + Database.Relational.Query.Monad.Restrict + Database.Relational.Query.Monad.Assign + Database.Relational.Query.Relation + Database.Relational.Query.Effect + Database.Relational.Query.Scalar + Database.Relational.Query.Type + Database.Relational.Query.Derives + Database.Relational.Query.TH + + other-modules: + Database.Relational.Query.Internal.SQL + Database.Relational.Query.Internal.Product + Database.Relational.Query.Monad.Trans.JoinState + Database.Relational.Query.Monad.Trans.Qualify + + build-depends: base <5 + , array + , containers + , transformers + , time + , old-locale + , bytestring + , text + , dlist + , template-haskell + , sql-words + , names-th + , persistable-record + + hs-source-dirs: src + ghc-options: -Wall + + default-language: Haskell2010 + +test-suite SQLs + build-depends: base <5 + , Cabal + , relational-query + + type: detailed-0.9 + test-module: SQLs + other-modules: + Tool + Model + + hs-source-dirs: test + ghc-options: -Wall + + default-language: Haskell2010 + + +source-repository head + type: git + location: https://github.com/khibino/haskell-relational-record + +source-repository head + type: mercurial + location: https://bitbucket.org/khibino/haskell-relational-record diff --git a/src/Database/Relational/Query.hs b/src/Database/Relational/Query.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Query.hs @@ -0,0 +1,81 @@ +-- | +-- Module : Database.Relational.Query +-- Copyright : 2013 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module is integrated module of Query. +module Database.Relational.Query ( + module Database.Relational.Query.Table, + module Database.Relational.Query.SQL, + module Database.Relational.Query.Pure, + module Database.Relational.Query.Pi, + module Database.Relational.Query.Constraint, + module Database.Relational.Query.Context, + module Database.Relational.Query.Expr, + module Database.Relational.Query.Component, + module Database.Relational.Query.Sub, + module Database.Relational.Query.Projection, + module Database.Relational.Query.Projectable, + module Database.Relational.Query.ProjectableExtended, + module Database.Relational.Query.Monad.Class, + module Database.Relational.Query.Monad.Trans.Aggregating, + module Database.Relational.Query.Monad.Trans.Ordering, + module Database.Relational.Query.Monad.Trans.Assigning, + module Database.Relational.Query.Monad.Type, + module Database.Relational.Query.Monad.Simple, + module Database.Relational.Query.Monad.Aggregate, + module Database.Relational.Query.Monad.Unique, + module Database.Relational.Query.Monad.Restrict, + module Database.Relational.Query.Monad.Assign, + module Database.Relational.Query.Relation, + module Database.Relational.Query.Scalar, + module Database.Relational.Query.Type, + module Database.Relational.Query.Effect, + module Database.Relational.Query.Derives + ) where + +import Database.Relational.Query.Table (Table, TableDerivable (..)) +import Database.Relational.Query.SQL (updateOtherThanKeySQL, insertSQL) +import Database.Relational.Query.Pure +import Database.Relational.Query.Pi +import Database.Relational.Query.Constraint + (Key, tableConstraint, projectionKey, + uniqueKey, -- notNullKey, + HasConstraintKey(constraintKey), + derivedUniqueKey, -- derivedNotNullKey, + Primary, Unique, NotNull) +import Database.Relational.Query.Context +import Database.Relational.Query.Expr hiding (fromJust, just) +import Database.Relational.Query.Component + (Config (..), defaultConfig, ProductUnitSupport (..), Order (..)) +import Database.Relational.Query.Sub (SubQuery, unitSQL, queryWidth) +import Database.Relational.Query.Projection (Projection, list) +import Database.Relational.Query.Projectable +import Database.Relational.Query.ProjectableExtended +import Database.Relational.Query.Monad.Class + (MonadQualify, MonadRestrict, MonadQuery, MonadAggregate, + distinct, all', on, wheres, groupBy, having, onE, wheresE, havingE) +import Database.Relational.Query.Monad.Trans.Aggregating + (groupBy', key, key', set, bkey, rollup, cube, groupingSets) +import Database.Relational.Query.Monad.Trans.Ordering (orderBy, asc, desc) +import Database.Relational.Query.Monad.Trans.Assigning (assignTo, (<-#)) +import Database.Relational.Query.Monad.Type +import Database.Relational.Query.Monad.Simple (QuerySimple, SimpleQuery) +import Database.Relational.Query.Monad.Aggregate + (QueryAggregate, AggregatedQuery, Window, partitionBy, over) +import Database.Relational.Query.Monad.Unique (QueryUnique) +import Database.Relational.Query.Monad.Restrict (Restrict) +import Database.Relational.Query.Monad.Assign (Assign) +import Database.Relational.Query.Relation +import Database.Relational.Query.Scalar (ScalarDegree) +import Database.Relational.Query.Type hiding + (unsafeTypedQuery, unsafeTypedKeyUpdate, unsafeTypedUpdate, + unsafeTypedInsert, unsafeTypedInsertQuery, unsafeTypedDelete) +import Database.Relational.Query.Effect +import Database.Relational.Query.Derives + +{-# ANN module "HLint: ignore Use import/export shortcut" #-} diff --git a/src/Database/Relational/Query/Component.hs b/src/Database/Relational/Query/Component.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Query/Component.hs @@ -0,0 +1,262 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} + +-- | +-- Module : Database.Relational.Query.Component +-- Copyright : 2013 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module provides untyped components for query. +module Database.Relational.Query.Component ( + -- * Type for column SQL string + ColumnSQL, columnSQL, columnSQL', showsColumnSQL, + + -- * Configuration type for query + Config (productUnitSupport, chunksInsertSize, normalizedTableName), + defaultConfig, + ProductUnitSupport (..), Duplication (..), + + -- * Duplication attribute + showsDuplication, + + -- * Query restriction + QueryRestriction, composeWhere, composeHaving, + + -- * Types for aggregation + AggregateColumnRef, + + AggregateBitKey, AggregateSet, AggregateElem, + + aggregateColumnRef, aggregateEmpty, + aggregatePowerKey, aggregateGroupingSet, + aggregateRollup, aggregateCube, aggregateSets, + + composeGroupBy, composePartitionBy, + + -- * Types for ordering + Order (..), OrderColumn, OrderingTerm, OrderingTerms, + composeOrderBy, + + -- * Types for assignments + AssignColumn, AssignTerm, Assignment, Assignments, composeSets, + + -- * Compose window clause + composeOver +) where + +import Data.Monoid (Monoid (..), (<>)) + +import qualified Database.Relational.Query.Context as Context +import Database.Relational.Query.Expr (Expr, exprAnd) +import Database.Relational.Query.Expr.Unsafe (sqlExpr) + +import Database.Relational.Query.Internal.SQL (StringSQL, stringSQL, showStringSQL) +import Language.SQL.Keyword (Keyword(..), (|*|), (.=.)) + +import qualified Language.SQL.Keyword as SQL + + +-- | Simple wrap type +newtype ColumnSQL' a = ColumnSQL a + +instance Functor ColumnSQL' where + fmap f (ColumnSQL c) = ColumnSQL $ f c + +-- | Column SQL string type +type ColumnSQL = ColumnSQL' StringSQL + +-- | 'ColumnSQL' from string +columnSQL :: String -> ColumnSQL +columnSQL = columnSQL' . stringSQL + +-- | 'ColumnSQL' from 'StringSQL' +columnSQL' :: StringSQL -> ColumnSQL +columnSQL' = ColumnSQL + +-- | String from ColumnSQL +stringFromColumnSQL :: ColumnSQL -> String +stringFromColumnSQL = showStringSQL . showsColumnSQL + +-- | StringSQL from ColumnSQL +showsColumnSQL :: ColumnSQL -> StringSQL +showsColumnSQL (ColumnSQL c) = c + +instance Show ColumnSQL where + show = stringFromColumnSQL + + +-- | Configuration type. +data Config = + Config + { productUnitSupport :: ProductUnitSupport + , chunksInsertSize :: Int + , normalizedTableName :: Bool + } deriving Show + +-- | Default configuration. +defaultConfig :: Config +defaultConfig = Config { productUnitSupport = PUSupported + , chunksInsertSize = 256 + , normalizedTableName = True + } + +-- | Unit of product is supported or not. +data ProductUnitSupport = PUSupported | PUNotSupported deriving Show + + +-- | Result record duplication attribute +data Duplication = All | Distinct deriving Show + +-- | Compose duplication attribute string. +showsDuplication :: Duplication -> StringSQL +showsDuplication = dup where + dup All = ALL + dup Distinct = DISTINCT + + +-- | Type for restriction of query. +type QueryRestriction c = [Expr c Bool] + +-- | Compose SQL String from 'QueryRestriction'. +composeRestrict :: Keyword -> QueryRestriction c -> StringSQL +composeRestrict k = d where + d [] = mempty + d e@(_:_) = k <> sqlExpr (foldr1 exprAnd e) + +-- | Compose WHERE clause from 'QueryRestriction'. +composeWhere :: QueryRestriction Context.Flat -> StringSQL +composeWhere = composeRestrict WHERE + +-- | Compose HAVING clause from 'QueryRestriction'. +composeHaving :: QueryRestriction Context.Aggregated -> StringSQL +composeHaving = composeRestrict HAVING + + +-- | Type for group-by term +type AggregateColumnRef = ColumnSQL + +-- | Type for group key. +newtype AggregateBitKey = AggregateBitKey [AggregateColumnRef] deriving Show + +-- | Type for grouping set +newtype AggregateSet = AggregateSet [AggregateElem] deriving Show + +-- | Type for group-by tree +data AggregateElem = ColumnRef AggregateColumnRef + | Rollup [AggregateBitKey] + | Cube [AggregateBitKey] + | GroupingSets [AggregateSet] + deriving Show + +-- | Single term aggregation element. +aggregateColumnRef :: AggregateColumnRef -> AggregateElem +aggregateColumnRef = ColumnRef + +-- | Key of aggregation power set. +aggregatePowerKey :: [AggregateColumnRef] -> AggregateBitKey +aggregatePowerKey = AggregateBitKey + +-- | Single grouping set. +aggregateGroupingSet :: [AggregateElem] -> AggregateSet +aggregateGroupingSet = AggregateSet + +-- | Rollup aggregation element. +aggregateRollup :: [AggregateBitKey] -> AggregateElem +aggregateRollup = Rollup + +-- | Cube aggregation element. +aggregateCube :: [AggregateBitKey] -> AggregateElem +aggregateCube = Cube + +-- | Grouping sets aggregation. +aggregateSets :: [AggregateSet] -> AggregateElem +aggregateSets = GroupingSets + +-- | Empty aggregation. +aggregateEmpty :: [AggregateElem] +aggregateEmpty = [] + +showsAggregateColumnRef :: AggregateColumnRef -> StringSQL +showsAggregateColumnRef = showsColumnSQL + +commaed :: [StringSQL] -> StringSQL +commaed = SQL.fold (|*|) + +pComma :: (a -> StringSQL) -> [a] -> StringSQL +pComma qshow = SQL.paren . commaed . map qshow + +showsAggregateBitKey :: AggregateBitKey -> StringSQL +showsAggregateBitKey (AggregateBitKey ts) = pComma showsAggregateColumnRef ts + +-- | Compose GROUP BY clause from AggregateElem list. +composeGroupBy :: [AggregateElem] -> StringSQL +composeGroupBy = d where + d [] = mempty + d es@(_:_) = GROUP <> BY <> rec es + keyList op ss = op <> pComma showsAggregateBitKey ss + rec = commaed . map showsE + showsGs (AggregateSet s) = SQL.paren $ rec s + showsE (ColumnRef t) = showsAggregateColumnRef t + showsE (Rollup ss) = keyList ROLLUP ss + showsE (Cube ss) = keyList CUBE ss + showsE (GroupingSets ss) = GROUPING <> SETS <> pComma showsGs ss + +-- | Compose PARTITION BY clause from AggregateColumnRef list. +composePartitionBy :: [AggregateColumnRef] -> StringSQL +composePartitionBy = d where + d [] = mempty + d ts@(_:_) = PARTITION <> BY <> commaed (map showsAggregateColumnRef ts) + +-- | Order direction. Ascendant or Descendant. +data Order = Asc | Desc deriving Show + +-- | Type for order-by column +type OrderColumn = ColumnSQL + +-- | Type for order-by term +type OrderingTerm = (Order, OrderColumn) + +-- | Type for order-by terms +type OrderingTerms = [OrderingTerm] + +-- | Compose ORDER BY clause from OrderingTerms +composeOrderBy :: OrderingTerms -> StringSQL +composeOrderBy = d where + d [] = mempty + d ts@(_:_) = ORDER <> BY <> commaed (map showsOt ts) + showsOt (o, e) = showsColumnSQL e <> order o + order Asc = ASC + order Desc = DESC + + +-- | Column SQL String +type AssignColumn = ColumnSQL + +-- | Value SQL String +type AssignTerm = ColumnSQL + +-- | Assignment pair +type Assignment = (AssignColumn, AssignTerm) + +-- | Assignment pair list. +type Assignments = [Assignment] + +-- | Compose SET clause from 'Assignments'. +composeSets :: Assignments -> StringSQL +composeSets as = assigns where + assignList = foldr (\ (col, term) r -> + (showsColumnSQL col .=. showsColumnSQL term) : r) + [] as + assigns | null assignList = error "Update assignment list is null!" + | otherwise = SET <> commaed assignList + + +-- | Compose /OVER (PARTITION BY ... )/ clause. +composeOver :: [AggregateColumnRef] -> OrderingTerms -> StringSQL +composeOver pts ots = + OVER <> SQL.paren (composePartitionBy pts <> composeOrderBy ots) diff --git a/src/Database/Relational/Query/Constraint.hs b/src/Database/Relational/Query/Constraint.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Query/Constraint.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Database.Relational.Query.Constraint +-- Copyright : 2013 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module provides proof object definitions of constraint key. +-- Difference between this module and "Database.Record.KeyConstraint" is +-- typed constraint key column definition is included in this module. +module Database.Relational.Query.Constraint ( + -- * Constraint Key proof object + Key, indexes, unsafeDefineConstraintKey, + tableConstraint, projectionKey, + + -- unsafeReturnKey, -- unsafeAppendConstraint, + + -- * Derivation rules + uniqueKey, -- notNullKey, + + -- * Inference rules + HasConstraintKey (..), + derivedUniqueKey, -- derivedNotNullKey, + + -- * Constraint types + Primary, Unique, NotNull + ) where + + +import Database.Relational.Query.Pi (Pi) +import qualified Database.Relational.Query.Pi.Unsafe as UnsafePi +import Database.Record.KeyConstraint + (KeyConstraint, unsafeSpecifyKeyConstraint, + Primary, Unique, NotNull) + +import qualified Database.Record.KeyConstraint as C +import Database.Record (PersistableRecordWidth, PersistableWidth (persistableWidth)) + + +-- | Constraint Key proof object. Constraint type 'c', record type 'r' and columns type 'ct'. +data Key c r ct = Key [Int] (PersistableRecordWidth ct) + +-- | Index of key which specifies constraint key. +indexes :: Key c r ct -> [Int] +indexes (Key is _) = is + +-- | Width of key. +width :: Key c r ct -> PersistableRecordWidth ct +width (Key _ w) = w + +-- | Unsafely generate constraint 'Key' proof object using specified key index. +unsafeDefineConstraintKey :: PersistableWidth ct + => [Int] -- ^ Key indexes which specify this constraint key + -> Key c r ct -- ^ Result constraint key proof object +unsafeDefineConstraintKey ixs = Key ixs persistableWidth + +-- | Get table constraint 'KeyConstraint' proof object from constraint 'Key'. +tableConstraint :: Key c r ct -> KeyConstraint c r +tableConstraint = unsafeSpecifyKeyConstraint . indexes + +-- | Get projection path proof object from constraint 'Key'. +projectionKey :: Key c r ct -> Pi r ct +projectionKey k = UnsafePi.defineDirectPi' w ixs where + ixs = indexes k + w = width k + +-- | Unsafe. Make constraint key to add column phantom type +unsafeReturnKey :: PersistableWidth ct + => KeyConstraint c r -> Key c r ct +unsafeReturnKey = unsafeDefineConstraintKey . C.indexes + +-- -- | Unsafe. Make constraint key to add constraint phantom type +-- unsafeAppendConstraint :: Pi r ct -> Key c r ct +-- unsafeAppendConstraint = unsafeDefineConstraintKey . leafIndex + + +-- | Map from table constraint into constraint 'Key'. +mapConstraint :: PersistableWidth ct + => (KeyConstraint c0 r -> KeyConstraint c1 r) + -> Key c0 r ct + -> Key c1 r ct +mapConstraint f = unsafeReturnKey . f . tableConstraint + +-- | Derive 'Unique' constraint 'Key' from 'Primary' constraint 'Key' +uniqueKey :: PersistableWidth ct + => Key Primary r ct -> Key Unique r ct +uniqueKey = mapConstraint C.unique + +-- -- | Derive 'NotNull' constraint 'Key' from 'Primary' constraint 'Key' +-- notNullKey :: Key Primary r ct -> Key NotNull r ct +-- notNullKey = mapConstraint C.notNull + + +-- | Constraint 'Key' inference interface. +class PersistableWidth ct => HasConstraintKey c r ct where + -- | Infer constraint key. + constraintKey :: Key c r ct + +-- | Infered 'Unique' constraint 'Key'. +-- Record type 'r' has unique key which type is 'ct' derived from primay key. +derivedUniqueKey :: HasConstraintKey Primary r ct => Key Unique r ct +derivedUniqueKey = uniqueKey constraintKey + +-- -- | Infered 'NotNull' constraint 'Key'. +-- -- Record type 'r' has not-null key which type is 'ct' derived from primay key. +-- derivedNotNullKey :: HasConstraintKey Primary r ct => Key NotNull r ct +-- derivedNotNullKey = notNullKey constraintKey diff --git a/src/Database/Relational/Query/Context.hs b/src/Database/Relational/Query/Context.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Query/Context.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE EmptyDataDecls #-} + +-- | +-- Module : Database.Relational.Query.Context +-- Copyright : 2013 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module defines query context tag types. +module Database.Relational.Query.Context ( + Flat, Aggregated, Exists, OverWindow, + + Set, SetList, Power, + ) where + +-- | Type tag for flat (not-aggregated) query +data Flat + +-- | Type tag for aggregated query +data Aggregated + +-- | Type tag for exists predicate +data Exists + +-- | Type tag for window function building +data OverWindow + + +-- | Type tag for normal aggregatings set +data Set + +-- | Type tag for aggregatings GROUPING SETS +data SetList + +-- | Type tag for aggregatings power set +data Power diff --git a/src/Database/Relational/Query/Derives.hs b/src/Database/Relational/Query/Derives.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Query/Derives.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE FlexibleContexts #-} + +-- | +-- Module : Database.Relational.Query.Derives +-- Copyright : 2013 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module defines typed SQLs derived from type informations. +module Database.Relational.Query.Derives ( + -- * Query derivation + specifiedKey, + + unique, + + primary', primary, + + -- * Update derivation + updateByConstraintKey, + primaryUpdate, + + updateValuesWithKey, + + -- * Derived objects from table + derivedUniqueRelation + ) where + +import Database.Record (PersistableWidth, ToSql (recordToSql)) +import Database.Record.ToSql (unsafeUpdateValuesWithIndexes) +import Database.Relational.Query.Table (Table, TableDerivable) +import Database.Relational.Query.Pi.Unsafe (Pi, unsafeExpandIndexes) +import Database.Relational.Query.Projection (Projection) +import qualified Database.Relational.Query.Projection as Projection +import Database.Relational.Query.Projectable (placeholder, (.=.)) +import Database.Relational.Query.ProjectableExtended ((!)) +import Database.Relational.Query.Monad.Class (wheres) +import Database.Relational.Query.Relation + (Relation, derivedRelation, relation, relation', query, UniqueRelation, unsafeUnique) +import Database.Relational.Query.Constraint + (Key, Primary, Unique, projectionKey, uniqueKey, + HasConstraintKey(constraintKey)) +import qualified Database.Relational.Query.Constraint as Constraint +import Database.Relational.Query.Type (KeyUpdate, typedKeyUpdate) + + +-- | Query restricted with specified key. +specifiedKey :: PersistableWidth p + => Pi a p -- ^ Unique key proof object which record type is 'a' and key type is 'p'. + -> Relation () a -- ^ 'Relation' to add restriction. + -> Relation p a -- ^ Result restricted 'Relation' +specifiedKey key rel = relation' $ do + q <- query rel + (param, ()) <- placeholder (\ph -> wheres $ q ! key .=. ph) + return (param, q) + +-- | Query restricted with specified unique key. +unique :: PersistableWidth p + => Key Unique a p -- ^ Unique key proof object which record type is 'a' and key type is 'p'. + -> Relation () a -- ^ 'Relation' to add restriction. + -> Relation p a -- ^ Result restricted 'Relation' +unique = specifiedKey . projectionKey + +-- | Query restricted with specified primary key. +primary' :: PersistableWidth p + => Key Primary a p -- ^ Primary key proof object which record type is 'a' and key type is 'p'. + -> Relation () a -- ^ 'Relation' to add restriction. + -> Relation p a -- ^ Result restricted 'Relation' +primary' = specifiedKey . projectionKey + +-- | Query restricted with infered primary key. +primary :: HasConstraintKey Primary a p + => Relation () a -- ^ 'Relation' to add restriction. + -> Relation p a -- ^ Result restricted 'Relation' +primary = primary' constraintKey + + +-- | Convert from Haskell type `r` into SQL value `q` list expected by update form like +-- +-- /UPDATE SET c0 = ?, c1 = ?, ..., cn = ? WHERE key0 = ? AND key1 = ? AND key2 = ? ... / +-- +-- using derived 'RecordToSql' proof object. +updateValuesWithKey :: ToSql q r + => Pi r p + -> r + -> [q] +updateValuesWithKey = unsafeUpdateValuesWithIndexes recordToSql . unsafeExpandIndexes + +-- | Typed 'KeyUpdate' using specified constraint key. +updateByConstraintKey :: Table r -- ^ 'Table' to update + -> Key c r p -- ^ Key with constraint 'c', record type 'r' and columns type 'p' + -> KeyUpdate p r -- ^ Result typed 'Update' +updateByConstraintKey table' = typedKeyUpdate table' . Constraint.projectionKey + +-- | Typed 'KeyUpdate' using infered primary key. +primaryUpdate :: (HasConstraintKey Primary r p) + => Table r -- ^ 'Table' to update + -> KeyUpdate p r -- ^ Result typed 'Update' +primaryUpdate table' = updateByConstraintKey table' (uniqueKey constraintKey) + +-- | 'UniqueRelation' infered from table. +derivedUniqueRelation :: TableDerivable r + => Key Unique r k -- ^ Unique key proof object which record type is 'a' and key type is 'p'. + -> Projection c k -- ^ Unique key value to specify. + -> UniqueRelation () c r -- ^ Result restricted 'Relation' +derivedUniqueRelation uk kp = unsafeUnique . relation $ do + r <- query derivedRelation + wheres $ r ! projectionKey uk .=. Projection.unsafeChangeContext kp + return r diff --git a/src/Database/Relational/Query/Effect.hs b/src/Database/Relational/Query/Effect.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Query/Effect.hs @@ -0,0 +1,133 @@ +-- | +-- Module : Database.Relational.Query.Effect +-- Copyright : 2013 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module defines effect statements +-- like update and delete. +module Database.Relational.Query.Effect ( + -- * Object to express simple restriction. + Restriction, RestrictionContext, restriction, restriction', + + -- * Object to express update target columns and restriction. + UpdateTarget, UpdateTargetContext, updateTarget, updateTarget', + liftTargetAllColumn, liftTargetAllColumn', + updateTargetAllColumn, updateTargetAllColumn', + + -- * Generate SQL from restriction. + sqlWhereFromRestriction, + sqlFromUpdateTarget + ) where + +import Data.Monoid ((<>)) +import Control.Monad (void) + +import Database.Record (PersistableWidth) + +import Database.Relational.Query.Internal.SQL (StringSQL, showStringSQL) +import Database.Relational.Query.Context (Flat) +import Database.Relational.Query.Pi (id') +import Database.Relational.Query.Table (Table, TableDerivable, derivedTable) +import Database.Relational.Query.Component (composeWhere, composeSets) +import Database.Relational.Query.Projection (Projection) +import qualified Database.Relational.Query.Projection as Projection +import Database.Relational.Query.Projectable + (PlaceHolders, placeholder, addPlaceHolders, (><), rightId) + +import Database.Relational.Query.Monad.Trans.Assigning (assignings, (<-#)) +import Database.Relational.Query.Monad.Restrict (Restrict, RestrictedStatement) +import qualified Database.Relational.Query.Monad.Restrict as Restrict +import Database.Relational.Query.Monad.Assign (AssignStatement) +import qualified Database.Relational.Query.Monad.Assign as Assign + + +-- | Restriction type with place-holder parameter 'p' and projection record type 'r'. +newtype Restriction p r = Restriction (Projection Flat r -> Restrict ()) + +-- | Not finalized 'Restrict' monad type. +type RestrictionContext p r = RestrictedStatement r (PlaceHolders p) + +-- | Finalize 'Restrict' monad and generate 'Restriction'. +restriction :: RestrictedStatement r () -> Restriction () r +restriction = Restriction + +-- | Finalize 'Restrict' monad and generate 'Restriction' with place-holder parameter 'p' +restriction' :: RestrictedStatement r (PlaceHolders p) -> Restriction p r +restriction' = Restriction . (void .) + +runRestriction :: Restriction p r + -> RestrictedStatement r (PlaceHolders p) +runRestriction (Restriction qf) = + fmap fst . addPlaceHolders . qf + +-- | SQL WHERE clause 'StringSQL' string from 'Restriction'. +sqlWhereFromRestriction :: Table r -> Restriction p r -> StringSQL +sqlWhereFromRestriction tbl (Restriction q) = composeWhere rs + where (_ph, rs) = Restrict.extract (q $ Projection.unsafeFromTable tbl) + +-- | Show where clause. +instance TableDerivable r => Show (Restriction p r) where + show = showStringSQL . sqlWhereFromRestriction derivedTable + +-- | UpdateTarget type with place-holder parameter 'p' and projection record type 'r'. +newtype UpdateTarget p r = UpdateTarget (AssignStatement r ()) + +-- | Not finalized 'Target' monad type. +type UpdateTargetContext p r = AssignStatement r (PlaceHolders p) + +-- | Finalize 'Target' monad and generate 'UpdateTarget'. +updateTarget :: AssignStatement r () + -> UpdateTarget () r +updateTarget = UpdateTarget + +-- | Finalize 'Target' monad and generate 'UpdateTarget' with place-holder parameter 'p'. +updateTarget' :: AssignStatement r (PlaceHolders p) + -> UpdateTarget p r +updateTarget' qf = UpdateTarget $ void . qf + +_runUpdateTarget :: UpdateTarget p r + -> AssignStatement r (PlaceHolders p) +_runUpdateTarget (UpdateTarget qf) = + fmap fst . addPlaceHolders . qf + +updateAllColumn :: PersistableWidth r + => Restriction p r + -> AssignStatement r (PlaceHolders (r, p)) +updateAllColumn rs proj = do + (ph0, ()) <- placeholder (\ph -> id' <-# ph) + ph1 <- assignings $ runRestriction rs proj + return $ ph0 >< ph1 + +-- | Lift 'Restriction' to 'UpdateTarget'. Update target columns are all. +liftTargetAllColumn :: PersistableWidth r + => Restriction () r + -> UpdateTarget r r +liftTargetAllColumn rs = updateTarget' $ \proj -> fmap rightId $ updateAllColumn rs proj + +-- | Lift 'Restriction' to 'UpdateTarget'. Update target columns are all. With placefolder type 'p'. +liftTargetAllColumn' :: PersistableWidth r + => Restriction p r + -> UpdateTarget (r, p) r +liftTargetAllColumn' rs = updateTarget' $ updateAllColumn rs + +-- | Finalize 'Restrict' monad and generate 'UpdateTarget'. Update target columns are all. +updateTargetAllColumn :: PersistableWidth r + => RestrictedStatement r () + -> UpdateTarget r r +updateTargetAllColumn = liftTargetAllColumn . restriction + +-- | Finalize 'Restrict' monad and generate 'UpdateTarget'. Update target columns are all. With placefolder type 'p'. +updateTargetAllColumn' :: PersistableWidth r + => RestrictedStatement r (PlaceHolders p) + -> UpdateTarget (r, p) r +updateTargetAllColumn' = liftTargetAllColumn' . restriction' + + +-- | SQL SET clause and WHERE clause 'StringSQL' string from 'UpdateTarget' +sqlFromUpdateTarget :: Table r -> UpdateTarget p r -> StringSQL +sqlFromUpdateTarget tbl (UpdateTarget q) = composeSets (asR tbl) <> composeWhere rs + where ((_ph, asR), rs) = Assign.extract (q (Projection.unsafeFromTable tbl)) diff --git a/src/Database/Relational/Query/Expr.hs b/src/Database/Relational/Query/Expr.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Query/Expr.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE FlexibleInstances #-} + +-- | +-- Module : Database.Relational.Query.Expr +-- Copyright : 2013 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module defines phantom typed SQL expression object. +-- Contains normal interfaces. +module Database.Relational.Query.Expr ( + -- * Typed SQL Expression + Expr, + + valueExpr, + + -- * Type conversion + just, fromJust, + + exprAnd + ) where + +import Prelude hiding (and, or) + +import Database.Relational.Query.Expr.Unsafe (Expr(Expr), sqlExpr) +import Database.Relational.Query.Pure (ShowConstantTermsSQL (showConstantTermsSQL)) +import Database.Relational.Query.Internal.SQL (stringSQL, rowStringSQL) + +import qualified Language.SQL.Keyword as SQL + + +-- | Typed constant SQL expression from Haskell value. +valueExpr :: ShowConstantTermsSQL ft => ft -> Expr p ft +valueExpr = Expr . rowStringSQL . map stringSQL . showConstantTermsSQL + +-- | Unsafely cast phantom type. +unsafeCastExpr :: Expr p a -> Expr p b +unsafeCastExpr = Expr . sqlExpr + +-- | Convert phantom type into 'Maybe'. +just :: Expr p ft -> Expr p (Maybe ft) +just = unsafeCastExpr + +-- | Allowed only for having or where 'Expr'. +-- So NULL expression result will be possible. +-- Behavior around boolean is strongly dependent on RDBMS impelemetations. +fromJust :: Expr p (Maybe ft) -> Expr p ft +fromJust = unsafeCastExpr + +-- | AND operator for 'Expr'. +exprAnd :: Expr p Bool -> Expr p Bool -> Expr p Bool +exprAnd a b = Expr . SQL.paren $ SQL.and (sqlExpr a) (sqlExpr b) diff --git a/src/Database/Relational/Query/Expr/Unsafe.hs b/src/Database/Relational/Query/Expr/Unsafe.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Query/Expr/Unsafe.hs @@ -0,0 +1,32 @@ +-- | +-- Module : Database.Relational.Query.Expr.Unsafe +-- Copyright : 2013 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module defines phantom typed SQL expression object. +-- Contains internal structure and unsafe interfaces. +module Database.Relational.Query.Expr.Unsafe ( + -- * Typed SQL Expression + Expr(Expr), sqlExpr, showExpr + ) where + +import Database.Relational.Query.Internal.SQL (StringSQL, showStringSQL) + +-- | Phantom typed SQL expression object. Project from projection type 'p'. +newtype Expr p a = Expr StringSQL + +-- | Get SQL expression from typed object. +sqlExpr :: Expr p t -> StringSQL +sqlExpr (Expr s) = s + +-- | Get SQL string from typed object. +showExpr :: Expr p t -> String +showExpr = showStringSQL . sqlExpr + +-- | Show expression. +instance Show (Expr p a) where + show = showExpr diff --git a/src/Database/Relational/Query/Internal/Product.hs b/src/Database/Relational/Query/Internal/Product.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Query/Internal/Product.hs @@ -0,0 +1,104 @@ +-- | +-- Module : Database.Relational.Query.Internal.Product +-- Copyright : 2013 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module defines product structure to compose SQL join. +module Database.Relational.Query.Internal.Product ( + -- * Product tree type + NodeAttr (..), ProductTree (..), + Node, node, nodeAttr, nodeTree, + growRight, -- growLeft, + growProduct, product, restrictProduct, + ) where + +import Prelude hiding (and, product) +import Database.Relational.Query.Context (Flat) +import Database.Relational.Query.Expr (exprAnd) +import qualified Database.Relational.Query.Expr as Expr +import Data.Monoid ((<>)) +import Data.Foldable (Foldable (foldMap)) + + +type Expr = Expr.Expr Flat + +-- | node attribute for product. +data NodeAttr = Just' | Maybe deriving Show + +-- | Product tree type. Product tree is constructed by left node and right node. +data ProductTree q = Leaf q + | Join !(Node q) !(Node q) !(Maybe (Expr Bool)) + deriving Show + +-- | Product node. node attribute and product tree. +data Node q = Node !NodeAttr !(ProductTree q) deriving Show + +-- | Get node attribute. +nodeAttr :: Node q -> NodeAttr +nodeAttr (Node a _) = a where + +-- | Get tree from node. +nodeTree :: Node q -> ProductTree q +nodeTree (Node _ t) = t + +-- | Foldable instance of ProductTree +instance Foldable ProductTree where + foldMap f = rec where + rec (Leaf q) = f q + rec (Join (Node _ lp) (Node _ rp) _ ) = rec lp <> rec rp + +-- | Make product node from node attribute and product tree. +node :: NodeAttr -- ^ Node attribute + -> ProductTree q -- ^ Product tree + -> Node q -- ^ Result node +node = Node + +-- | Push new tree into product right term. +growRight :: Maybe (Node q) -- ^ Current tree + -> (NodeAttr, ProductTree q) -- ^ New tree to push into right + -> Node q -- ^ Result node +growRight = d where + d Nothing (naR, q) = node naR q + d (Just l) (naR, q) = node Just' $ Join l (node naR q) Nothing + +-- -- | Push new tree node into product left term. +-- growLeft :: Node q -- ^ New node to push into left +-- -> NodeAttr -- ^ Node attribute to replace rigth node attribute. +-- -> Maybe (Node q) -- ^ Current tree +-- -> Node q -- ^ Result node +-- growLeft = d where +-- d q _naR Nothing = q -- error is better? +-- d q naR (Just r) = node Just' $ Join q (node naR (nodeTree r)) Nothing + +-- | Push new leaf node into product right term. +growProduct :: Maybe (Node q) -- ^ Current tree + -> (NodeAttr, q) -- ^ New leaf to push into right + -> Node q -- ^ Result node +growProduct = match where + match t (na, q) = growRight t (na, Leaf q) + +-- | Just make product of two node. +product :: Node q -- ^ Left node + -> Node q -- ^ Right node + -> Maybe (Expr Bool) -- ^ Join restriction + -> ProductTree q -- ^ Result tree +product = Join + +-- | Add restriction into top product of product tree. +restrictProduct' :: ProductTree q -- ^ Product to restrict + -> Expr Bool -- ^ Restriction to add + -> ProductTree q -- ^ Result product +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 `exprAnd` rs') + d leaf'@(Leaf _) _ = leaf' -- or error on compile + +-- | Add restriction into top product of product tree node. +restrictProduct :: Node q -- ^ Target node which has product to restrict + -> Expr Bool -- ^ Restriction to add + -> Node q -- ^ Result node +restrictProduct (Node a t) e = node a (restrictProduct' t e) diff --git a/src/Database/Relational/Query/Internal/SQL.hs b/src/Database/Relational/Query/Internal/SQL.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Query/Internal/SQL.hs @@ -0,0 +1,50 @@ +-- | +-- Module : Database.Relational.Query.Internal.SQL +-- Copyright : 2014 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module provides SQL string wrap interfaces. +module Database.Relational.Query.Internal.SQL ( + StringSQL, stringSQL, showStringSQL, + + rowStringSQL, rowPlaceHolderStringSQL, + + rowListStringSQL, rowListStringString + ) where + +import Language.SQL.Keyword (Keyword, word, wordShow, fold, (|*|), paren) + + +-- | String wrap type for SQL strings. +type StringSQL = Keyword + +-- | 'StringSQL' from 'String'. +stringSQL :: String -> StringSQL +stringSQL = word + +-- | 'StringSQL' to 'String'. +showStringSQL :: StringSQL -> String +showStringSQL = wordShow + +-- | Row String of SQL values. +rowStringSQL :: [StringSQL] -> StringSQL +rowStringSQL = d where + d [] = error "Projection: no columns." + d [c] = c + d cs = paren $ fold (|*|) cs + +-- | Place holder row String of SQL. +rowPlaceHolderStringSQL :: Int -> StringSQL +rowPlaceHolderStringSQL = rowStringSQL . (`replicate` stringSQL "?") + +-- | Rows String of SQL. +rowListStringSQL :: [StringSQL] -> StringSQL +rowListStringSQL = paren . fold (|*|) + +-- | Rows String of SQL. String type version. +rowListStringString :: [String] -> String +rowListStringString = wordShow . rowListStringSQL . map word diff --git a/src/Database/Relational/Query/Monad/Aggregate.hs b/src/Database/Relational/Query/Monad/Aggregate.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Query/Monad/Aggregate.hs @@ -0,0 +1,107 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +-- | +-- Module : Database.Relational.Query.Monad.Aggregate +-- Copyright : 2013 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module contains definitions about aggregated query type. +module Database.Relational.Query.Monad.Aggregate ( + -- * Aggregated Query + QueryAggregate, + AggregatedQuery, + + toSQL, + + toSubQuery, + + Window, partitionBy, over + ) where + +import Data.Functor.Identity (Identity (runIdentity)) + +import Database.Relational.Query.Internal.SQL (showStringSQL) +import Database.Relational.Query.Context (Flat, Aggregated, OverWindow) +import Database.Relational.Query.Projection (Projection) +import qualified Database.Relational.Query.Projection as Projection +import Database.Relational.Query.Component + (AggregateColumnRef, Duplication, QueryRestriction, OrderingTerms, AggregateElem, composeOver) +import Database.Relational.Query.Sub (SubQuery, aggregatedSubQuery, JoinProduct) +import qualified Database.Relational.Query.Sub as SubQuery +import Database.Relational.Query.Projectable (SqlProjectable, unsafeProjectSql, unsafeShowSql) + +import Database.Relational.Query.Monad.Class (MonadRestrict(..), MonadQualify(..), MonadPartition (..)) +import Database.Relational.Query.Monad.Trans.Join (join') +import Database.Relational.Query.Monad.Trans.Restricting + (Restrictings, restrictings, extractRestrict) +import Database.Relational.Query.Monad.Trans.Aggregating + (aggregatings, extractAggregateTerms, AggregatingSetT, PartitioningSet) +import Database.Relational.Query.Monad.Trans.Ordering + (Orderings, orderings, OrderedQuery, extractOrderingTerms) +import Database.Relational.Query.Monad.Type (ConfigureQuery, askConfig, QueryCore, extractCore) + + +-- | Aggregated query monad type. +type QueryAggregate = Orderings Aggregated (Restrictings Aggregated (AggregatingSetT QueryCore)) + +-- | Aggregated query type. AggregatedQuery r == QueryAggregate (Projection Aggregated r). +type AggregatedQuery r = OrderedQuery Aggregated (Restrictings Aggregated (AggregatingSetT QueryCore)) r + +-- | Partition monad type for partition-by clause. +type Window c = Orderings c (PartitioningSet c) + +-- | Lift from qualified table forms into 'QueryAggregate'. +aggregatedQuery :: ConfigureQuery a -> QueryAggregate a +aggregatedQuery = orderings . restrictings . aggregatings . restrictings . join' + +-- | Restricted 'MonadRestrict' instance. +instance MonadRestrict Flat q => MonadRestrict Flat (Restrictings Aggregated q) where + restrictContext = restrictings . restrictContext + +-- | Instance to lift from qualified table forms into 'QueryAggregate'. +instance MonadQualify ConfigureQuery QueryAggregate where + liftQualify = aggregatedQuery + +extract :: AggregatedQuery r + -> ConfigureQuery ((((((Projection Aggregated r, OrderingTerms), + QueryRestriction Aggregated), + [AggregateElem]), + QueryRestriction Flat), + JoinProduct), Duplication) +extract = extractCore . extractAggregateTerms . extractRestrict . extractOrderingTerms + +-- | Run 'AggregatedQuery' to get SQL with 'ConfigureQuery' computation. +toSQL :: AggregatedQuery r -- ^ 'AggregatedQuery' to run + -> ConfigureQuery String -- ^ Result SQL string with 'ConfigureQuery' computation +toSQL = fmap SubQuery.toSQL . toSubQuery + +-- | Run 'AggregatedQuery' to get 'SubQuery' with 'ConfigureQuery' computation. +toSubQuery :: AggregatedQuery r -- ^ 'AggregatedQuery' to run + -> ConfigureQuery SubQuery -- ^ Result 'SubQuery' with 'ConfigureQuery' computation +toSubQuery q = do + ((((((pj, ot), grs), ag), rs), pd), da) <- extract q + c <- askConfig + return $ aggregatedSubQuery c (Projection.untype pj) da pd rs ag grs ot + +-- | Add /PARTITION BY/ term into context. +partitionBy :: Projection c r -> Window c () +partitionBy = mapM_ unsafeAddPartitionKey . Projection.columns + +extractWindow :: Window c a -> ((a, OrderingTerms), [AggregateColumnRef]) +extractWindow = runIdentity . extractAggregateTerms . extractOrderingTerms + +-- | Operator to make window function projection. +over :: SqlProjectable (Projection c) + => Projection OverWindow a + -> Window c () + -> Projection c a +wp `over` win = unsafeProjectSql $ unwords [unsafeShowSql wp, showStringSQL (composeOver pt ot)] where + (((), ot), pt) = extractWindow win diff --git a/src/Database/Relational/Query/Monad/Assign.hs b/src/Database/Relational/Query/Monad/Assign.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Query/Monad/Assign.hs @@ -0,0 +1,41 @@ +-- | +-- Module : Database.Relational.Query.Monad.Assign +-- Copyright : 2013 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module contains definitions about restrict context with assignment monad type. +module Database.Relational.Query.Monad.Assign ( + -- * Monad to restrict target records with assignment. + Assign, AssignStatement, + -- updateStatement, + extract, + ) where + +import Database.Relational.Query.Component (QueryRestriction, Assignments) +import Database.Relational.Query.Context (Flat) +import Database.Relational.Query.Table (Table) +import Database.Relational.Query.Projection (Projection) +import Database.Relational.Query.Monad.Restrict (Restrict) +import qualified Database.Relational.Query.Monad.Restrict as Restrict +import Database.Relational.Query.Monad.Trans.Assigning (Assignings, extractAssignments) + +-- | Target update monad type used from update statement and merge statement. +type Assign r = Assignings r Restrict + +-- | AssignStatement type synonym. +-- Specifying assignments and restrictions like update statement. +-- Projection record type must be +-- the same as 'Target' type parameter 'r'. +type AssignStatement r a = Projection Flat r -> Assign r a + +-- -- | 'return' of 'Update' +-- updateStatement :: a -> Assignings r (Restrictings Identity) a +-- updateStatement = assignings . restrictings . Identity + +-- | Run 'Assign'. +extract :: Assign r a -> ((a, Table r -> Assignments), QueryRestriction Flat) +extract = Restrict.extract . extractAssignments diff --git a/src/Database/Relational/Query/Monad/Class.hs b/src/Database/Relational/Query/Monad/Class.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Query/Monad/Class.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +-- | +-- Module : Database.Relational.Query.Monad.Class +-- Copyright : 2013 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module defines query building interface classes. +module Database.Relational.Query.Monad.Class ( + -- * Query interface classes + MonadQualify (..), MonadQualifyUnique(..), MonadRestrict (..), + MonadQuery (..), MonadAggregate (..), MonadPartition (..), + + all', distinct, + onE, on, wheresE, wheres, + groupBy, + havingE, having + ) where + +import Database.Relational.Query.Context (Flat, Aggregated) +import Database.Relational.Query.Expr (Expr) +import Database.Relational.Query.Component + (Duplication (..), AggregateElem, AggregateColumnRef, aggregateColumnRef) +import Database.Relational.Query.Projection (Projection) +import qualified Database.Relational.Query.Projection as Projection +import Database.Relational.Query.Projectable (expr) +import Database.Relational.Query.Sub (SubQuery, Qualified) + +import Database.Relational.Query.Internal.Product (NodeAttr) + +-- | Restrict context interface +class (Functor m, Monad m) => MonadRestrict c m where + -- | Add restriction to this context. + restrictContext :: Expr c (Maybe Bool) -- ^ 'Expr' 'Projection' which represent restriction + -> m () -- ^ Restricted query context + +-- | Query building interface. +class (Functor m, Monad m) => MonadQuery m where + -- | Specify duplication. + setDuplication :: Duplication -> m () + -- | Add restriction to last join. + restrictJoin :: Expr Flat (Maybe Bool) -- ^ 'Expr' 'Projection' which represent restriction + -> m () -- ^ Restricted query context + -- | Unsafely join subquery with this query. + unsafeSubQuery :: NodeAttr -- ^ Attribute maybe or just + -> Qualified SubQuery -- ^ 'SubQuery' to join + -> m (Projection Flat r) -- ^ Result joined context and 'SubQuery' result projection. + +-- | Lift interface from base qualify monad. +class (Functor q, Monad q, MonadQuery m) => MonadQualify q m where + -- | Lift from qualify monad 'q' into 'MonadQuery' m. + -- Qualify monad qualifies table form 'SubQuery'. + liftQualify :: q a -> m a + +-- | Lift interface from base qualify monad. Another constraint to support unique query. +class (Functor q, Monad q, MonadQuery m) => MonadQualifyUnique q m where + -- | Lift from qualify monad 'q' into 'MonadQuery' m. + -- Qualify monad qualifies table form 'SubQuery'. + liftQualifyUnique :: q a -> m a + +-- | Aggregated query building interface extends 'MonadQuery'. +class MonadQuery m => MonadAggregate m where + -- | Add /group by/ term into context and get aggregated projection. + unsafeAddAggregateElement :: AggregateElem -- ^ Grouping element to add into group by clause + -> m () -- ^ Result context + +-- | Window specification building interface. +class Monad m => MonadPartition m where + unsafeAddPartitionKey :: AggregateColumnRef -- ^ Partitioning key to add into partition by clause + -> m () -- ^ Result context + +-- | Specify ALL attribute to query context. +all' :: MonadQuery m => m () +all' = setDuplication All + +-- | Specify DISTINCT attribute to query context. +distinct :: MonadQuery m => m () +distinct = setDuplication Distinct + +-- | Add restriction to last join. +onE :: MonadQuery m => Expr Flat (Maybe Bool) -> m () +onE = restrictJoin + +-- | Add restriction to last join. Projection type version. +on :: MonadQuery m => Projection Flat (Maybe Bool) -> m () +on = restrictJoin . expr + +-- | Add restriction to this query. +wheresE :: MonadRestrict Flat m => Expr Flat (Maybe Bool) -> m () +wheresE = restrictContext + +-- | Add restriction to this query. Projection type version. +wheres :: MonadRestrict Flat m => Projection Flat (Maybe Bool) -> m () +wheres = restrictContext . expr + +-- | Add /GROUP BY/ term into context and get aggregated projection. +groupBy :: MonadAggregate m + => Projection Flat r -- ^ Projection to add into group by + -> m (Projection Aggregated r) -- ^ Result context and aggregated projection +groupBy p = do + mapM_ unsafeAddAggregateElement [ aggregateColumnRef col | col <- Projection.columns p] + return $ Projection.unsafeToAggregated p + +-- | Add restriction to this aggregated query. +havingE :: MonadRestrict Aggregated m => Expr Aggregated (Maybe Bool) -> m () +havingE = restrictContext + +-- | Add restriction to this aggregated query. Aggregated Projection type version. +having :: MonadRestrict Aggregated m => Projection Aggregated (Maybe Bool) -> m () +having = restrictContext . expr diff --git a/src/Database/Relational/Query/Monad/Restrict.hs b/src/Database/Relational/Query/Monad/Restrict.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Query/Monad/Restrict.hs @@ -0,0 +1,41 @@ +-- | +-- Module : Database.Relational.Query.Monad.Restrict +-- Copyright : 2013 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module contains definitions about simple restrict context monad type. +module Database.Relational.Query.Monad.Restrict ( + -- * Monad to restrict target records. + Restrict, RestrictedStatement, + + -- restricted, + extract + ) where + +import Data.Functor.Identity (Identity (..), runIdentity) + +import Database.Relational.Query.Component (QueryRestriction) +import Database.Relational.Query.Context (Flat) +import Database.Relational.Query.Projection (Projection) +import Database.Relational.Query.Monad.Trans.Restricting (Restrictings, extractRestrict) + + +-- | Restrict only monad type used from update statement and delete statement. +type Restrict = Restrictings Flat Identity + +-- | RestrictedStatement type synonym. +-- Projection record type 'r' must be +-- the same as 'Restrictings' type parameter 'r'. +type RestrictedStatement r a = Projection Flat r -> Restrict a + +-- -- | 'return' of 'Restrict' +-- restricted :: a -> Restrict a +-- restricted = restrict . Identity + +-- | Run 'Restrict' to get 'QueryRestriction'. +extract :: Restrict a -> (a, QueryRestriction Flat) +extract = runIdentity . extractRestrict diff --git a/src/Database/Relational/Query/Monad/Simple.hs b/src/Database/Relational/Query/Monad/Simple.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Query/Monad/Simple.hs @@ -0,0 +1,71 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +-- | +-- Module : Database.Relational.Query.Monad.Simple +-- Copyright : 2013 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module contains definitions about simple (not-aggregated) query type. +module Database.Relational.Query.Monad.Simple ( + -- * Simple query + QuerySimple, SimpleQuery, + + simple, + + toSQL, + toSubQuery + ) where + +import Database.Relational.Query.Context (Flat) +import Database.Relational.Query.Projection (Projection) +import qualified Database.Relational.Query.Projection as Projection + +import Database.Relational.Query.Monad.Class (MonadQualify(..)) +import Database.Relational.Query.Monad.Trans.Join (join') +import Database.Relational.Query.Monad.Trans.Restricting (restrictings) +import Database.Relational.Query.Monad.Trans.Ordering + (Orderings, orderings, OrderedQuery, extractOrderingTerms) +import Database.Relational.Query.Monad.Type (ConfigureQuery, askConfig, QueryCore, extractCore) + +import Database.Relational.Query.Component (Duplication, QueryRestriction, OrderingTerms) +import Database.Relational.Query.Sub (SubQuery, flatSubQuery, JoinProduct) +import qualified Database.Relational.Query.Sub as SubQuery + + +-- | Simple query (not-aggregated) monad type. +type QuerySimple = Orderings Flat QueryCore + +-- | Simple query (not-aggregated) query type. 'SimpleQuery' r == 'QuerySimple' ('Projection' r). +type SimpleQuery r = OrderedQuery Flat QueryCore r + +-- | Lift from qualified table forms into 'QuerySimple'. +simple :: ConfigureQuery a -> QuerySimple a +simple = orderings . restrictings . join' + +-- | Instance to lift from qualified table forms into 'QuerySimple'. +instance MonadQualify ConfigureQuery (Orderings Flat QueryCore) where + liftQualify = simple + +extract :: SimpleQuery r + -> ConfigureQuery ((((Projection Flat r, OrderingTerms), QueryRestriction Flat), + JoinProduct), Duplication) +extract = extractCore . extractOrderingTerms + +-- | Run 'SimpleQuery' to get SQL string with 'Qualify' computation. +toSQL :: SimpleQuery r -- ^ 'SimpleQuery' to run + -> ConfigureQuery String -- ^ Result SQL string with 'Qualify' computation +toSQL = fmap SubQuery.toSQL . toSubQuery + +-- | Run 'SimpleQuery' to get 'SubQuery' with 'Qualify' computation. +toSubQuery :: SimpleQuery r -- ^ 'SimpleQuery' to run + -> ConfigureQuery SubQuery -- ^ Result 'SubQuery' with 'Qualify' computation +toSubQuery q = do + ((((pj, ot), rs), pd), da) <- extract q + c <- askConfig + return $ flatSubQuery c (Projection.untype pj) da pd rs ot diff --git a/src/Database/Relational/Query/Monad/Trans/Aggregating.hs b/src/Database/Relational/Query/Monad/Trans/Aggregating.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Query/Monad/Trans/Aggregating.hs @@ -0,0 +1,173 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +-- | +-- Module : Database.Relational.Query.Monad.Trans.Aggregating +-- Copyright : 2013 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module defines monad transformer which lift +-- from 'MonadQuery' into Aggregated query. +module Database.Relational.Query.Monad.Trans.Aggregating ( + -- * Transformer into aggregated query + Aggregatings, aggregatings, + + AggregatingSetT, AggregatingSetListT, AggregatingPowerSetT, PartitioningSetT, + + -- * Result + extractAggregateTerms, + + -- * Grouping sets support + AggregateKey, + + groupBy', + + AggregatingSet, AggregatingPowerSet, AggregatingSetList, PartitioningSet, + key, key', set, + bkey, rollup, cube, groupingSets + ) where + +import Control.Monad.Trans.Class (MonadTrans (lift)) +import Control.Monad.Trans.Writer (WriterT, runWriterT, tell) +import Control.Applicative (Applicative, pure, (<$>)) +import Control.Arrow (second) +import Data.DList (DList, toList) + +import Data.Functor.Identity (Identity (runIdentity)) + +import Database.Relational.Query.Context (Flat, Aggregated, Set, Power, SetList) +import Database.Relational.Query.Component + (AggregateColumnRef, AggregateElem, aggregateColumnRef, AggregateSet, aggregateGroupingSet, + AggregateBitKey, aggregatePowerKey, aggregateRollup, aggregateCube, aggregateSets) +import Database.Relational.Query.Projection (Projection) +import qualified Database.Relational.Query.Projection as Projection + +import Database.Relational.Query.Monad.Class + (MonadRestrict(..), MonadQuery(..), MonadAggregate(..), MonadPartition(..)) + + +-- | Type to accumulate aggregating context. +-- Type 'ac' is aggregating-context type like aggregating key set building, +-- aggregating key sets set building and partition key set building. +-- Type 'at' is aggregating term type. +newtype Aggregatings ac at m a = + Aggregatings (WriterT (DList at) m a) + deriving (MonadTrans, Monad, Functor, Applicative) + +-- | Lift to 'Aggregatings'. +aggregatings :: Monad m => m a -> Aggregatings ac at m a +aggregatings = lift + +-- | Context type building one grouping set. +type AggregatingSetT = Aggregatings Set AggregateElem + +-- | Context type building grouping sets list. +type AggregatingSetListT = Aggregatings SetList AggregateSet + +-- | Context type building power group set. +type AggregatingPowerSetT = Aggregatings Power AggregateBitKey + +-- | Context type building partition keys set. +type PartitioningSetT c = Aggregatings c AggregateColumnRef + +-- | Aggregated 'MonadRestrict'. +instance MonadRestrict c m => MonadRestrict c (AggregatingSetT m) where + restrictContext = aggregatings . restrictContext + +-- | Aggregated 'MonadQuery'. +instance MonadQuery m => MonadQuery (AggregatingSetT m) where + setDuplication = aggregatings . setDuplication + restrictJoin = aggregatings . restrictJoin + unsafeSubQuery na = aggregatings . unsafeSubQuery na + +unsafeAggregateWithTerm :: Monad m => at -> Aggregatings ac at m () +unsafeAggregateWithTerm = Aggregatings . tell . pure + +-- | Aggregated query instance. +instance MonadQuery m => MonadAggregate (AggregatingSetT m) where + unsafeAddAggregateElement = unsafeAggregateWithTerm + +-- | Partition clause instance +instance Monad m => MonadPartition (PartitioningSetT c m) where + unsafeAddPartitionKey = unsafeAggregateWithTerm + +-- | Run 'Aggregatings' to get terms list. +extractAggregateTerms :: (Monad m, Functor m) => Aggregatings ac at m a -> m (a, [at]) +extractAggregateTerms (Aggregatings ac) = second toList <$> runWriterT ac + + +-- | Typeful aggregate element. +newtype AggregateKey a = AggregateKey (a, AggregateElem) + +-- | Add /GROUP BY/ element into context and get aggregated projection. +groupBy' :: MonadAggregate m + => AggregateKey a + -> m a +groupBy' (AggregateKey (p, c)) = do + unsafeAddAggregateElement c + return p + +extractTermList :: Aggregatings ac at Identity a -> (a, [at]) +extractTermList = runIdentity . extractAggregateTerms + +-- | Context monad type to build single grouping set. +type AggregatingSet = AggregatingSetT Identity + +-- | Context monad type to build grouping power set. +type AggregatingPowerSet = AggregatingPowerSetT Identity + +-- | Context monad type to build grouping set list. +type AggregatingSetList = AggregatingSetListT Identity + +-- | Context monad type to build partition keys set. +type PartitioningSet c = PartitioningSetT c Identity + +-- | Specify key of single grouping set from Projection. +key :: Projection Flat r + -> AggregatingSet (Projection Aggregated (Maybe r)) +key p = do + mapM_ unsafeAggregateWithTerm [ aggregateColumnRef col | col <- Projection.columns p] + return . Projection.just $ Projection.unsafeToAggregated p + +-- | Specify key of single grouping set. +key' :: AggregateKey a + -> AggregatingSet a +key' (AggregateKey (p, c)) = do + unsafeAggregateWithTerm c + return p + +-- | Finalize and specify single grouping set. +set :: AggregatingSet a + -> AggregatingSetList a +set s = do + let (p, c) = second aggregateGroupingSet . extractTermList $ s + unsafeAggregateWithTerm c + return p + +-- | Specify key of rollup and cube power set. +bkey :: Projection Flat r + -> AggregatingPowerSet (Projection Aggregated (Maybe r)) +bkey p = do + unsafeAggregateWithTerm . aggregatePowerKey $ Projection.columns p + return . Projection.just $ Projection.unsafeToAggregated p + +finalizePower :: ([AggregateBitKey] -> AggregateElem) + -> AggregatingPowerSet a -> AggregateKey a +finalizePower finalize pow = AggregateKey . second finalize . extractTermList $ pow + +-- | Finalize grouping power set as rollup power set. +rollup :: AggregatingPowerSet a -> AggregateKey a +rollup = finalizePower aggregateRollup + +-- | Finalize grouping power set as cube power set. +cube :: AggregatingPowerSet a -> AggregateKey a +cube = finalizePower aggregateCube + +-- | Finalize grouping set list. +groupingSets :: AggregatingSetList a -> AggregateKey a +groupingSets = AggregateKey . second aggregateSets . extractTermList diff --git a/src/Database/Relational/Query/Monad/Trans/Assigning.hs b/src/Database/Relational/Query/Monad/Trans/Assigning.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Query/Monad/Trans/Assigning.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +-- | +-- Module : Database.Relational.Query.Monad.Trans.Assigning +-- Copyright : 2013 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module defines monad transformer which lift +-- from context into context with assigning. +module Database.Relational.Query.Monad.Trans.Assigning ( + -- * Transformer into context with assignments + Assignings, assignings, + + -- * API of context with assignments + assignTo, (<-#), AssignTarget, + + -- * Result SQL set clause + extractAssignments + ) where + +import Database.Relational.Query.Context (Flat) +import Control.Monad.Trans.Class (MonadTrans (lift)) +import Control.Monad.Trans.Writer (WriterT, runWriterT, tell) +import Control.Applicative (Applicative, pure, (<$>)) +import Control.Arrow (second) +import Data.Monoid (mconcat) +import Data.DList (DList, toList) + +import Database.Relational.Query.Component (Assignment, Assignments) +import Database.Relational.Query.Pi (Pi) +import Database.Relational.Query.Table (Table) +import Database.Relational.Query.Projection (Projection) +import qualified Database.Relational.Query.Projection as Projection + +import Database.Relational.Query.Monad.Class (MonadRestrict(..)) + + +-- | Type to accumulate assigning context. +-- Type 'r' is table record type. +newtype Assignings r m a = + Assignings (WriterT (Table r -> DList Assignment) m a) + deriving (MonadTrans, Monad, Functor, Applicative) + +-- | Lift to 'Assignings' +assignings :: Monad m => m a -> Assignings r m a +assignings = lift + +-- | 'MonadRestrict' with ordering. +instance MonadRestrict c m => MonadRestrict c (Assignings r m) where + restrictContext = assignings . restrictContext + +-- | Target of assignment. +type AssignTarget r v = Pi r v + +targetProjection :: AssignTarget r v -> Table r -> Projection Flat v +targetProjection pi' tbl = Projection.pi (Projection.unsafeFromTable tbl) pi' + +-- | Add an assignment. +assignTo :: Monad m => Projection Flat v -> AssignTarget r v -> Assignings r m () +assignTo vp target = Assignings . tell + $ \t -> mconcat $ zipWith (curry pure) (leftsR t) rights where + leftsR = Projection.columns . targetProjection target + rights = Projection.columns vp + +-- | Add and assginment. +(<-#) :: Monad m => AssignTarget r v -> Projection Flat v -> Assignings r m () +(<-#) = flip assignTo + +infix 4 <-# + +-- | Run 'Assignings' to get 'Assignments' +extractAssignments :: (Monad m, Functor m) + => Assignings r m a + -> m (a, Table r -> Assignments) +extractAssignments (Assignings ac) = second (toList .) <$> runWriterT ac diff --git a/src/Database/Relational/Query/Monad/Trans/Config.hs b/src/Database/Relational/Query/Monad/Trans/Config.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Query/Monad/Trans/Config.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- | +-- Module : Database.Relational.Query.Monad.Trans.Config +-- Copyright : 2013 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module defines monad transformer which requires query generate configuration. +module Database.Relational.Query.Monad.Trans.Config ( + -- * Transformer into query with configuration + QueryConfig, queryConfig, + runQueryConfig, askQueryConfig + ) where + +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Reader (ReaderT, runReaderT, ask) +import Control.Applicative (Applicative) + +import Database.Relational.Query.Component (Config) + + +-- | 'ReaderT' type to require query generate configuration. +newtype QueryConfig m a = + QueryConfig (ReaderT Config m a) + deriving (Monad, Functor, Applicative) + +-- | Run 'QueryConfig' to expand with configuration +runQueryConfig :: QueryConfig m a -> Config -> m a +runQueryConfig (QueryConfig r) = runReaderT r + +-- | Lift to 'QueryConfig'. +queryConfig :: Monad m => m a -> QueryConfig m a +queryConfig = QueryConfig . lift + +-- | Read configuration. +askQueryConfig :: Monad m => QueryConfig m Config +askQueryConfig = QueryConfig ask diff --git a/src/Database/Relational/Query/Monad/Trans/Join.hs b/src/Database/Relational/Query/Monad/Trans/Join.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Query/Monad/Trans/Join.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- | +-- Module : Database.Relational.Query.Monad.Trans.Join +-- 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.Join ( + -- * Transformer into join query + QueryJoin, join', + + -- * Result + extractProduct + ) where + +import Prelude hiding (product) +import Control.Monad.Trans.Class (MonadTrans (lift)) +import Control.Monad.Trans.Writer (WriterT, runWriterT, tell) +import Control.Monad.Trans.State (modify, StateT, runStateT) +import Control.Applicative (Applicative, (<$>)) +import Control.Arrow (second, (***)) +import Data.Maybe (fromMaybe) +import Data.Monoid (Last (Last, getLast)) + +import Database.Relational.Query.Context (Flat) +import Database.Relational.Query.Monad.Trans.JoinState + (JoinContext, primeJoinContext, updateProduct, joinProduct) +import Database.Relational.Query.Internal.Product (NodeAttr, restrictProduct, growProduct) +import Database.Relational.Query.Projection (Projection) +import qualified Database.Relational.Query.Projection as Projection +import Database.Relational.Query.Expr (Expr, fromJust) +import Database.Relational.Query.Component (Duplication (All)) +import Database.Relational.Query.Sub (SubQuery, Qualified, JoinProduct) + +import Database.Relational.Query.Monad.Class (MonadQuery (..)) + + +-- | 'StateT' type to accumulate join product context. +newtype QueryJoin m a = + QueryJoin (StateT JoinContext (WriterT (Last Duplication) m) a) + deriving (Monad, Functor, Applicative) + +-- | Lift to 'QueryJoin' +join' :: Monad m => m a -> QueryJoin m a +join' = QueryJoin . lift . lift + +-- | Unsafely update join product context. +updateContext :: Monad m => (JoinContext -> JoinContext) -> QueryJoin m () +updateContext = QueryJoin . modify + +-- | Add last join product restriction. +updateJoinRestriction :: Monad m => Expr Flat (Maybe Bool) -> QueryJoin m () +updateJoinRestriction e = updateContext (updateProduct d) where + d Nothing = error "on: Product is empty! Restrict target product is not found!" + d (Just pt) = restrictProduct pt (fromJust e) + +-- | Joinable query instance. +instance (Monad q, Functor q) => MonadQuery (QueryJoin q) where + setDuplication = QueryJoin . lift . tell . Last . Just + restrictJoin = updateJoinRestriction + unsafeSubQuery = unsafeSubQueryWithAttr + +-- | Unsafely join subquery with this query. +unsafeSubQueryWithAttr :: Monad q + => NodeAttr -- ^ Attribute maybe or just + -> Qualified SubQuery -- ^ 'SubQuery' to join + -> QueryJoin q (Projection Flat r) -- ^ Result joined context and 'SubQuery' result projection. +unsafeSubQueryWithAttr attr qsub = do + updateContext (updateProduct (`growProduct` (attr, qsub))) + return $ Projection.unsafeFromQualifiedSubQuery qsub + +-- | Run 'QueryJoin' to get 'JoinProduct' +extractProduct :: Functor m => QueryJoin m a -> m ((a, JoinProduct), Duplication) +extractProduct (QueryJoin s) = (second joinProduct *** (fromMaybe All . getLast)) + <$> runWriterT (runStateT s primeJoinContext) diff --git a/src/Database/Relational/Query/Monad/Trans/JoinState.hs b/src/Database/Relational/Query/Monad/Trans/JoinState.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Query/Monad/Trans/JoinState.hs @@ -0,0 +1,43 @@ +-- | +-- Module : Database.Relational.Query.Monad.Trans.JoinState +-- Copyright : 2013 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module provides state definition for +-- "Database.Relational.Query.Monad.Trans.Join". +module Database.Relational.Query.Monad.Trans.JoinState ( + -- * Join context + JoinContext, primeJoinContext, updateProduct, joinProduct + ) where + +import Prelude hiding (product) + +import qualified Database.Relational.Query.Internal.Product as Product +import Database.Relational.Query.Sub (QueryProductNode, JoinProduct) + + +-- | JoinContext type for QueryJoin. +newtype JoinContext = + JoinContext + { product :: Maybe QueryProductNode + } + +-- | Initial 'JoinContext'. +primeJoinContext :: JoinContext +primeJoinContext = JoinContext Nothing + +-- | Update product of 'JoinContext'. +updateProduct' :: (Maybe QueryProductNode -> Maybe QueryProductNode) -> JoinContext -> JoinContext +updateProduct' uf ctx = ctx { product = uf . product $ ctx } + +-- | Update product of 'JoinContext'. +updateProduct :: (Maybe QueryProductNode -> QueryProductNode) -> JoinContext -> JoinContext +updateProduct uf = updateProduct' (Just . uf) + +-- | Finalize context to extract accumulated query product. +joinProduct :: JoinContext -> JoinProduct +joinProduct = fmap Product.nodeTree . product diff --git a/src/Database/Relational/Query/Monad/Trans/Ordering.hs b/src/Database/Relational/Query/Monad/Trans/Ordering.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Query/Monad/Trans/Ordering.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +-- | +-- Module : Database.Relational.Query.Monad.Trans.Ordering +-- Copyright : 2013 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module defines monad transformer which lift +-- from query into query with ordering. +module Database.Relational.Query.Monad.Trans.Ordering ( + -- * Transformer into query with ordering + Orderings, orderings, OrderedQuery, OrderingTerms, + + -- * API of query with ordering + orderBy, asc, desc, + + -- * Result + extractOrderingTerms + ) where + +import Control.Monad.Trans.Class (MonadTrans (lift)) +import Control.Monad.Trans.Writer (WriterT, runWriterT, tell) +import Control.Applicative (Applicative, pure, (<$>)) +import Control.Arrow (second) +import Data.DList (DList, toList) + +import Database.Relational.Query.Component + (Order(Asc, Desc), OrderColumn, OrderingTerm, OrderingTerms) +import Database.Relational.Query.Projection (Projection) +import qualified Database.Relational.Query.Projection as Projection + +import Database.Relational.Query.Monad.Class + (MonadRestrict(..), MonadQuery(..), MonadAggregate(..), MonadPartition(..)) + + +-- | Type to accumulate ordering context. +-- Type 'c' is ordering term projection context type. +newtype Orderings c m a = + Orderings (WriterT (DList OrderingTerm) m a) + deriving (MonadTrans, Monad, Functor, Applicative) + +-- | Lift to 'Orderings'. +orderings :: Monad m => m a -> Orderings c m a +orderings = lift + +-- | 'MonadRestrict' with ordering. +instance MonadRestrict rc m => MonadRestrict rc (Orderings c m) where + restrictContext = orderings . restrictContext + +-- | 'MonadQuery' with ordering. +instance MonadQuery m => MonadQuery (Orderings c m) where + setDuplication = orderings . setDuplication + restrictJoin = orderings . restrictJoin + unsafeSubQuery na = orderings . unsafeSubQuery na + +-- | 'MonadAggregate' with ordering. +instance MonadAggregate m => MonadAggregate (Orderings c m) where + unsafeAddAggregateElement = orderings . unsafeAddAggregateElement + +-- | 'MonadPartition' with ordering. +instance MonadPartition m => MonadPartition (Orderings c m) where + unsafeAddPartitionKey = orderings . unsafeAddPartitionKey + +-- | OrderedQuery type synonym. Projection must be the same as 'Orderings' type parameter 'p' +type OrderedQuery c m r = Orderings c m (Projection c r) + +-- | Ordering term projection type interface. +class ProjectableOrdering p where + orderTerms :: p t -> [OrderColumn] + +-- | 'Projection' is ordering term. +instance ProjectableOrdering (Projection c) where + orderTerms = Projection.columns + +-- | Add ordering terms. +updateOrderBys :: (Monad m, ProjectableOrdering (Projection c)) + => Order -- ^ Order direction + -> Projection c t -- ^ Ordering terms to add + -> Orderings c m () -- ^ Result context with ordering +updateOrderBys order p = Orderings . mapM_ tell $ terms where + terms = curry pure order `map` orderTerms p + +-- | Add ordering terms. +orderBy :: (Monad m, ProjectableOrdering (Projection c)) + => Projection c t -- ^ Ordering terms to add + -> Order -- ^ Order direction + -> Orderings c m () -- ^ Result context with ordering +orderBy = flip updateOrderBys + +-- | Add ascendant ordering term. +asc :: (Monad m, ProjectableOrdering (Projection c)) + => Projection c t -- ^ Ordering terms to add + -> Orderings c m () -- ^ Result context with ordering +asc = updateOrderBys Asc + +-- | Add descendant ordering term. +desc :: (Monad m, ProjectableOrdering (Projection c)) + => Projection c t -- ^ Ordering terms to add + -> Orderings c m () -- ^ Result context with ordering +desc = updateOrderBys Desc + +-- | Run 'Orderings' to get 'OrderingTerms' +extractOrderingTerms :: (Monad m, Functor m) => Orderings c m a -> m (a, OrderingTerms) +extractOrderingTerms (Orderings oc) = second toList <$> runWriterT oc diff --git a/src/Database/Relational/Query/Monad/Trans/Qualify.hs b/src/Database/Relational/Query/Monad/Trans/Qualify.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Query/Monad/Trans/Qualify.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- | +-- Module : Database.Relational.Query.Monad.Trans.Qualify +-- Copyright : 2013 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module defines monad transformer which qualify uniquely SQL table forms. +module Database.Relational.Query.Monad.Trans.Qualify ( + -- * Qualify monad + Qualify, qualify, + evalQualifyPrime, qualifyQuery + ) where + +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.State (StateT, runStateT, get, modify) +import Control.Applicative (Applicative) +import Control.Monad (liftM) + +import Database.Relational.Query.Sub (Qualified) +import qualified Database.Relational.Query.Sub as SubQuery + + +type AliasId = Int + +-- | Monad type to qualify SQL table forms. +newtype Qualify m a = + Qualify (StateT AliasId m a) + deriving (Monad, Functor, Applicative) + +-- | Run qualify monad with initial state to get only result. +evalQualifyPrime :: Monad m => Qualify m a -> m a +evalQualifyPrime (Qualify s) = fst `liftM` runStateT s 0 {- primary alias id -} + +-- | Generated new qualifier on internal state. +newAlias :: Monad m => Qualify m AliasId +newAlias = Qualify $ do + ai <- get + modify (+ 1) + return ai + +-- | Lift to 'Qualify' +qualify :: Monad m => m a -> Qualify m a +qualify = Qualify . lift + +-- | Get qualifyed table form query. +qualifyQuery :: Monad m + => query -- ^ Query to qualify + -> Qualify m (Qualified query) -- ^ Result with updated state +qualifyQuery query = + do n <- newAlias + return . SubQuery.qualify query $ SubQuery.Qualifier n diff --git a/src/Database/Relational/Query/Monad/Trans/Restricting.hs b/src/Database/Relational/Query/Monad/Trans/Restricting.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Query/Monad/Trans/Restricting.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +-- | +-- Module : Database.Relational.Query.Monad.Trans.Restricting +-- 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.Restricting ( + -- * Transformer into restricted context + Restrictings, restrictings, + + -- * Result + extractRestrict + ) where + +import Control.Monad.Trans.Class (MonadTrans (lift)) +import Control.Monad.Trans.Writer (WriterT, runWriterT, tell) +import Control.Applicative (Applicative, pure, (<$>)) +import Control.Arrow (second) +import Data.DList (DList, toList) + +import Database.Relational.Query.Expr (Expr, fromJust) +import Database.Relational.Query.Component (QueryRestriction) + +import Database.Relational.Query.Monad.Class (MonadRestrict(..), MonadQuery (..), MonadAggregate(..)) + + +-- | Type to accumulate query restrictions. +-- Type 'c' is context tag of restriction building like +-- Flat (where) or Aggregated (having). +newtype Restrictings c m a = + Restrictings (WriterT (DList (Expr c Bool)) m a) + deriving (MonadTrans, Monad, Functor, Applicative) + +-- | Lift to 'Restrictings' +restrictings :: Monad m => m a -> Restrictings c m a +restrictings = lift + +-- | Add whole query restriction. +updateRestriction :: Monad m => Expr c (Maybe Bool) -> Restrictings c m () +updateRestriction = Restrictings . tell . pure . fromJust + +-- | 'MonadRestrict' instance. +instance (Monad q, Functor q) => MonadRestrict c (Restrictings c q) where + restrictContext = updateRestriction + +-- | Restricted 'MonadQuery' instance. +instance MonadQuery q => MonadQuery (Restrictings c q) where + setDuplication = restrictings . setDuplication + restrictJoin = restrictings . restrictJoin + unsafeSubQuery a = restrictings . unsafeSubQuery a + +-- | Resticted 'MonadAggregate' instance. +instance MonadAggregate m => MonadAggregate (Restrictings c m) where + unsafeAddAggregateElement = restrictings . unsafeAddAggregateElement + +-- | Run 'Restrictings' to get 'QueryRestriction' +extractRestrict :: (Monad m, Functor m) => Restrictings c m a -> m (a, QueryRestriction c) +extractRestrict (Restrictings rc) = second toList <$> runWriterT rc diff --git a/src/Database/Relational/Query/Monad/Type.hs b/src/Database/Relational/Query/Monad/Type.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Query/Monad/Type.hs @@ -0,0 +1,49 @@ +-- | +-- Module : Database.Relational.Query.Monad.Type +-- Copyright : 2013 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module defines core query type. +module Database.Relational.Query.Monad.Type ( + -- * Core query monad + ConfigureQuery, configureQuery, qualifyQuery, askConfig, QueryCore, extractCore + ) where + +import Data.Functor.Identity (Identity, runIdentity) + +import Database.Relational.Query.Component (Config, Duplication, QueryRestriction) +import Database.Relational.Query.Sub (Qualified, JoinProduct) +import Database.Relational.Query.Context (Flat) +import qualified Database.Relational.Query.Monad.Trans.Qualify as Qualify +import Database.Relational.Query.Monad.Trans.Qualify (Qualify, qualify, evalQualifyPrime) +import Database.Relational.Query.Monad.Trans.Config (QueryConfig, runQueryConfig, askQueryConfig) +import Database.Relational.Query.Monad.Trans.Join (QueryJoin, extractProduct) +import Database.Relational.Query.Monad.Trans.Restricting (Restrictings, extractRestrict) + + +-- | Thin monad type for untyped structure. +type ConfigureQuery = Qualify (QueryConfig Identity) + +-- | Run 'ConfigureQuery' monad with initial state to get only result. +configureQuery :: ConfigureQuery q -> Config -> q +configureQuery cq c = runIdentity $ runQueryConfig (evalQualifyPrime cq) c + +-- | Get qualifyed table form query. +qualifyQuery :: a -> ConfigureQuery (Qualified a) +qualifyQuery = Qualify.qualifyQuery + +-- | Read configuration. +askConfig :: ConfigureQuery Config +askConfig = qualify askQueryConfig + +-- | Core query monad type used from flat(not-aggregated) query and aggregated query. +type QueryCore = Restrictings Flat (QueryJoin ConfigureQuery) + +-- | Extract 'QueryCore' computation. +extractCore :: QueryCore a + -> ConfigureQuery (((a, QueryRestriction Flat), JoinProduct), Duplication) +extractCore = extractProduct . extractRestrict diff --git a/src/Database/Relational/Query/Monad/Unique.hs b/src/Database/Relational/Query/Monad/Unique.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Query/Monad/Unique.hs @@ -0,0 +1,57 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- | +-- Module : Database.Relational.Query.Monad.Unique +-- Copyright : 2013 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module contains definitions about unique query type +-- to support scalar queries. +module Database.Relational.Query.Monad.Unique ( + QueryUnique, toSubQuery + ) where + +import Control.Applicative (Applicative) + +import Database.Relational.Query.Context (Flat) +import Database.Relational.Query.Projection (Projection) +import qualified Database.Relational.Query.Projection as Projection + +import Database.Relational.Query.Monad.Class (MonadQualifyUnique(..), MonadQuery) +import Database.Relational.Query.Monad.Trans.Join (join') +import Database.Relational.Query.Monad.Trans.Restricting (restrictings) +import Database.Relational.Query.Monad.Type (ConfigureQuery, askConfig, QueryCore, extractCore) + +import Database.Relational.Query.Component (Duplication, QueryRestriction) +import Database.Relational.Query.Sub (SubQuery, flatSubQuery, JoinProduct) + +-- | Unique query monad type. +newtype QueryUnique a = QueryUnique (QueryCore a) + deriving (MonadQuery, Monad, Applicative, Functor) + +-- | Lift from qualified table forms into 'QueryUnique'. +queryUnique :: ConfigureQuery a -> QueryUnique a +queryUnique = QueryUnique . restrictings . join' + +-- | Instance to lift from qualified table forms into 'QuerySimple'. +instance MonadQualifyUnique ConfigureQuery QueryUnique where + liftQualifyUnique = queryUnique + +extract :: QueryUnique a + -> ConfigureQuery (((a, QueryRestriction Flat), JoinProduct), Duplication) +extract (QueryUnique c) = extractCore c + +-- | Run 'SimpleQuery' to get 'SubQuery' with 'Qualify' computation. +toSubQuery :: QueryUnique (Projection c r) -- ^ 'QueryUnique' to run + -> ConfigureQuery SubQuery -- ^ Result 'SubQuery' with 'Qualify' computation +toSubQuery q = do + (((pj, rs), pd), da) <- extract q + c <- askConfig + return $ flatSubQuery c (Projection.untype pj) da pd rs [] diff --git a/src/Database/Relational/Query/Pi.hs b/src/Database/Relational/Query/Pi.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Query/Pi.hs @@ -0,0 +1,40 @@ +-- | +-- Module : Database.Relational.Query.Pi +-- Copyright : 2013 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module defines typed projection path objects. +-- Contains normal interfaces. +module Database.Relational.Query.Pi ( + -- * Projection path + Pi, pfmap, pap, (<.>), (), (), + + id', fst', snd' + ) where + +import Database.Record + (PersistableWidth, persistableWidth, PersistableRecordWidth) +import Database.Record.Persistable + (runPersistableRecordWidth) + +import Database.Relational.Query.Pi.Unsafe + (Pi, pfmap, pap, (<.>), (), (), definePi) + +-- | Identity projection path. +id' :: PersistableWidth a => Pi a a +id' = definePi 0 + +-- | Projection path for fst of tuple. +fst' :: PersistableWidth a => Pi (a, b) a -- ^ Projection path of fst. +fst' = definePi 0 + +snd'' :: PersistableWidth b => PersistableRecordWidth a -> Pi (a, b) b +snd'' wa = definePi (runPersistableRecordWidth wa) + +-- | Projection path for snd of tuple. +snd' :: (PersistableWidth a, PersistableWidth b) => Pi (a, b) b -- ^ Projection path of snd. +snd' = snd'' persistableWidth diff --git a/src/Database/Relational/Query/Pi/Unsafe.hs b/src/Database/Relational/Query/Pi/Unsafe.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Query/Pi/Unsafe.hs @@ -0,0 +1,144 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} + +-- | +-- Module : Database.Relational.Query.Pi.Unsafe +-- Copyright : 2013 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module defines typed projection path objects. +-- Contains internal structure and unsafe interfaces. +module Database.Relational.Query.Pi.Unsafe ( + -- * Projection path + Pi, + + pfmap, pap, + + width, + + (<.>), (), (), + + pi, + + definePi, defineDirectPi', defineDirectPi, + + unsafeExpandIndexes + ) where + +import Prelude hiding (pi) +import Data.Array (listArray, (!)) + +import Database.Record.Persistable + (PersistableRecordWidth, runPersistableRecordWidth, unsafePersistableRecordWidth, (<&>), + PersistableWidth (persistableWidth), maybeWidth) + +import Database.Relational.Query.Pure (ProductConstructor (..)) + +-- | Projection path primary structure type. +data Pi' r0 r1 = Leftest Int + | Map [Int] + +unsafePiAppend' :: Pi' a b' -> Pi' b c' -> Pi' a c +unsafePiAppend' = d where + d (Leftest i) (Leftest j) = Leftest $ i + j + d (Leftest i) (Map js) = Map $ map (i +) js + d (Map is) (Leftest j) = Map $ drop j is + d (Map is) (Map js) = Map [ is' ! j | j <- js ] where + is' = listArray (0, length is) is + +-- | Projection path from type 'r0' into type 'r1'. +-- This type also indicate key object which type is 'r1' for record type 'r0'. +data Pi r0 r1 = Pi (Pi' r0 r1) (PersistableRecordWidth r1) + +unsafePiAppend :: (PersistableRecordWidth c' -> PersistableRecordWidth c) + -> Pi a b' -> Pi b c' -> Pi a c +unsafePiAppend f (Pi p0 _) (Pi p1 w) = + Pi (p0 `unsafePiAppend'` p1) (f w) + +-- | Unsafely untype key to expand indexes. +unsafeExpandIndexes :: Pi a b -> [Int] +unsafeExpandIndexes = d where + d (Pi (Map is) _) = is + d (Pi (Leftest i) w) = [ i .. i + w' - 1 ] where + w' = runPersistableRecordWidth w + +-- | Unsafely cast width proof object of record. Result record must be same width. +unsafeCastRecordWidth :: PersistableRecordWidth a -> PersistableRecordWidth a' +unsafeCastRecordWidth = unsafePersistableRecordWidth . runPersistableRecordWidth + +unsafeCast :: Pi a b' -> Pi a b +unsafeCast = c where + d (Leftest i) = Leftest i + d (Map m) = Map m + c (Pi p w) = Pi (d p) (unsafeCastRecordWidth w) + +-- | Projectable fmap of 'Pi' type. +pfmap :: ProductConstructor (a -> b) + => (a -> b) -> Pi r a -> Pi r b +_ `pfmap` p = unsafeCast p + +-- | Projectable ap of 'Pi' type. +pap :: Pi r (a -> b) -> Pi r a -> Pi r b +pap b@(Pi _ wb) c@(Pi _ wc) = + Pi + (Map $ unsafeExpandIndexes b ++ unsafeExpandIndexes c) + (unsafeCastRecordWidth $ wb <&> wc) + +-- | Get record width proof object. +width' :: Pi r ct -> PersistableRecordWidth ct +width' (Pi _ w) = w + +-- | Get record width. +width :: Pi r a -> Int +width = runPersistableRecordWidth . width' + +-- | Compose projection path. +(<.>) :: Pi a b -> Pi b c -> Pi a c +(<.>) = unsafePiAppend id + +-- | Compose projection path. +() :: Pi a (Maybe b) -> Pi b c -> Pi a (Maybe c) +() = unsafePiAppend maybeWidth + +-- | Compose projection path. +() :: Pi a (Maybe b) -> Pi b (Maybe c) -> Pi a (Maybe c) +() = unsafePiAppend id + +infixl 8 <.>, , + +-- | Unsafely project untyped value list. +pi :: [a] -> Pi r0 r1 -> [a] +pi cs (Pi p' w) = d p' where + d (Leftest i) = take (runPersistableRecordWidth w) . drop i $ cs + d (Map is) = [cs' ! i | i <- is] + cs' = listArray (0, length cs) cs + +-- | Unsafely define projection path from type 'r0' into type 'r1'. +definePi' :: PersistableRecordWidth r1 + -> Int -- ^ Index of flat SQL value list + -> Pi r0 r1 -- ^ Result projection path +definePi' pw i = Pi (Leftest i) pw + +-- | Unsafely define projection path from type 'r0' into type 'r1'. +-- Use infered 'PersistableRecordWidth'. +definePi :: PersistableWidth r1 + => Int -- ^ Index of flat SQL value list + -> Pi r0 r1 -- ^ Result projection path +definePi = definePi' persistableWidth + +-- | Unsafely define projection path from type 'r0' into type 'r1'. +defineDirectPi' :: PersistableRecordWidth r1 + -> [Int] -- ^ Indexes of flat SQL value list + -> Pi r0 r1 -- ^ Result projection path +defineDirectPi' pw is = Pi (Map is) pw + +-- | Unsafely define projection path from type 'r0' into type 'r1'. +-- Use infered 'PersistableRecordWidth'. +defineDirectPi :: PersistableWidth r1 + => [Int] -- ^ Indexes of flat SQL value list + -> Pi r0 r1 -- ^ Result projection path +defineDirectPi = defineDirectPi' persistableWidth diff --git a/src/Database/Relational/Query/Projectable.hs b/src/Database/Relational/Query/Projectable.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Query/Projectable.hs @@ -0,0 +1,607 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Database.Relational.Query.Projectable +-- Copyright : 2013 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module defines operators on various polymorphic projections. +module Database.Relational.Query.Projectable ( + -- * Conversion between individual Projections + expr, + + -- * Projectable from SQL strings + SqlProjectable (unsafeProjectSqlTerms), unsafeProjectSql, + + -- * Projections of values + value, + valueTrue, valueFalse, + values, + unsafeValueNull, + + -- * Placeholders + PlaceHolders, addPlaceHolders, unsafePlaceHolders, + placeholder', placeholder, + + -- * Projectable into SQL strings + unsafeShowSqlExpr, + unsafeShowSqlProjection, + ProjectableShowSql (unsafeShowSql), + + -- * Operators + SqlBinOp, + unsafeBinOp, + + unsafeUniOp, + + (.=.), (.<.), (.<=.), (.>.), (.>=.), (.<>.), + + casesOrElse, casesOrElse', + caseSearch, caseSearchMaybe, case', caseMaybe, + in', and', or', + + isNothing, isJust, + fromMaybe', not', exists, + + (.||.), (?||?), + (.+.), (.-.), (./.), (.*.), negate', fromIntegral', showNum, + (?+?), (?-?), (?/?), (?*?), negateMaybe, fromIntegralMaybe, showNumMaybe, + + -- * Terms for Window function types + rank, denseRank, rowNumber, percentRank, cumeDist, + + dense_rank, row_number, percent_rank, cume_dist, + + -- * Zipping projections + projectZip, (><), + ProjectableIdZip (..), + + -- * 'Maybe' type projecitoins + ProjectableMaybe (just, flattenMaybe), + + -- * ProjectableFunctor and ProjectableApplicative + ProjectableFunctor (..), ProjectableApplicative (..), ipfmap + ) where + +import Prelude hiding (pi) + +import Data.Int (Int64) +import Data.String (IsString) +import Data.Monoid ((<>), mconcat) +import Control.Applicative ((<$>)) + +import Language.SQL.Keyword (Keyword) +import qualified Language.SQL.Keyword as SQL + +import Database.Record + (PersistableWidth, PersistableRecordWidth, derivedWidth, + HasColumnConstraint, NotNull) + +import Database.Relational.Query.Internal.SQL (stringSQL, showStringSQL, rowStringSQL) +import Database.Relational.Query.Context (Flat, Aggregated, Exists, OverWindow) +import Database.Relational.Query.Component (columnSQL, showsColumnSQL) +import Database.Relational.Query.Expr (Expr) +import qualified Database.Relational.Query.Expr as Expr +import qualified Database.Relational.Query.Expr.Unsafe as UnsafeExpr + +import Database.Relational.Query.Pure + (ShowConstantTermsSQL (showConstantTermsSQL), ProductConstructor (..)) +import Database.Relational.Query.Pi (Pi) +import qualified Database.Relational.Query.Pi as Pi + +import Database.Relational.Query.Projection + (Projection, unsafeFromColumns, columns, + ListProjection, unsafeShowSqlListProjection) +import qualified Database.Relational.Query.Projection as Projection + + +-- | Unsafely get SQL term from 'Proejction'. +unsafeShowSqlProjection :: Projection c r -> String +unsafeShowSqlProjection = showStringSQL . rowStringSQL . map showsColumnSQL . columns + +-- | 'Expr' from 'Projection' +exprOfProjection :: Projection c r -> Expr c r +exprOfProjection = UnsafeExpr.Expr . stringSQL . unsafeShowSqlProjection + +-- | Project from Projection type into expression type. +expr :: Projection p a -> Expr p a +expr = exprOfProjection + + +-- | Unsafely generate 'Projection' from SQL expression strings. +unsafeSqlTermsProjection :: [String] -> Projection c t +unsafeSqlTermsProjection = unsafeFromColumns . map columnSQL + +-- | Interface to project SQL terms unsafely. +class SqlProjectable p where + -- | Unsafely project from SQL expression strings. + unsafeProjectSqlTerms :: [String] -- ^ SQL expression strings + -> p t -- ^ Result projection object + +-- | Unsafely make 'Projection' from SQL terms. +instance SqlProjectable (Projection Flat) where + unsafeProjectSqlTerms = unsafeSqlTermsProjection + +-- | Unsafely make 'Projection' from SQL terms. +instance SqlProjectable (Projection Aggregated) where + unsafeProjectSqlTerms = unsafeSqlTermsProjection + +-- | Unsafely make 'Projection' from SQL terms. +instance SqlProjectable (Projection OverWindow) where + unsafeProjectSqlTerms = unsafeSqlTermsProjection + +-- | Unsafely make 'Expr' from SQL terms. +instance SqlProjectable (Expr p) where + unsafeProjectSqlTerms = UnsafeExpr.Expr . rowStringSQL . map stringSQL + +-- | Unsafely Project single SQL term. +unsafeProjectSql :: SqlProjectable p => String -> p t +unsafeProjectSql = unsafeProjectSqlTerms . (:[]) + +-- | Polymorphic projection of SQL null value. +unsafeValueNull :: SqlProjectable p => p (Maybe a) +unsafeValueNull = unsafeProjectSql "NULL" + +-- | Generate polymorphic projection of SQL constant values from Haskell value. +value :: (ShowConstantTermsSQL t, SqlProjectable p) => t -> p t +value = unsafeProjectSqlTerms . showConstantTermsSQL + +-- | Polymorphic proejction of SQL true value. +valueTrue :: (SqlProjectable p, ProjectableMaybe p) => p (Maybe Bool) +valueTrue = just $ value True + +-- | Polymorphic proejction of SQL false value. +valueFalse :: (SqlProjectable p, ProjectableMaybe p) => p (Maybe Bool) +valueFalse = just $ value False + +-- | Polymorphic proejction of SQL set value from Haskell list. +values :: (ShowConstantTermsSQL t, SqlProjectable p) => [t] -> ListProjection p t +values = Projection.list . map value + + +-- | Interface to get SQL term from projections. +class ProjectableShowSql p where + -- | Unsafely generate SQL expression string from projection object. + unsafeShowSql :: p a -- ^ Source projection object + -> String -- ^ Result SQL expression string. + +-- | Unsafely get SQL term from 'Expr'. +unsafeShowSqlExpr :: Expr p t -> String +unsafeShowSqlExpr = UnsafeExpr.showExpr + +-- | Unsafely get SQL term from 'Expr'. +instance ProjectableShowSql (Expr p) where + unsafeShowSql = unsafeShowSqlExpr + +-- | Unsafely get SQL term from 'Proejction'. +instance ProjectableShowSql (Projection c) where + unsafeShowSql = unsafeShowSqlProjection + + +-- | Binary operator type for SQL String. +type SqlBinOp = Keyword -> Keyword -> Keyword + +-- | Unsafely make projection unary operator from SQL keyword. +unsafeUniOp :: (ProjectableShowSql p0, SqlProjectable p1) + => (Keyword -> Keyword) -> p0 a -> p1 b +unsafeUniOp u = unsafeProjectSql . SQL.strUniOp u . unsafeShowSql + +unsafeFlatUniOp :: (SqlProjectable p, ProjectableShowSql p) + => Keyword -> p a -> p b +unsafeFlatUniOp kw = unsafeUniOp (SQL.paren . SQL.defineUniOp kw) + +parenBinStr :: SqlBinOp -> String -> String -> String +parenBinStr op = SQL.strBinOp $ \x y -> SQL.paren $ op x y + +-- | Unsafely make projection binary operator from string binary operator. +unsafeBinOp :: (SqlProjectable p, ProjectableShowSql p) + => SqlBinOp + -> p a -> p b -> p c +unsafeBinOp op a b = unsafeProjectSql + $ parenBinStr op (unsafeShowSql a) (unsafeShowSql b) + +-- | Unsafely make compare projection binary operator from string binary operator. +compareBinOp :: (SqlProjectable p, ProjectableShowSql p) + => SqlBinOp + -> p a -> p a -> p (Maybe Bool) +compareBinOp = unsafeBinOp + +-- | Unsafely make number projection binary operator from string binary operator. +monoBinOp :: (SqlProjectable p, ProjectableShowSql p) + => SqlBinOp + -> p a -> p a -> p a +monoBinOp = unsafeBinOp + + +-- | Compare operator corresponding SQL /=/ . +(.=.) :: (SqlProjectable p, ProjectableShowSql p) + => p ft -> p ft -> p (Maybe Bool) +(.=.) = compareBinOp (SQL..=.) + +-- | Compare operator corresponding SQL / p ft -> p ft -> p (Maybe Bool) +(.<.) = compareBinOp (SQL..<.) + +-- | Compare operator corresponding SQL /<=/ . +(.<=.) :: (SqlProjectable p, ProjectableShowSql p) + => p ft -> p ft -> p (Maybe Bool) +(.<=.) = compareBinOp (SQL..<=.) + +-- | Compare operator corresponding SQL />/ . +(.>.) :: (SqlProjectable p, ProjectableShowSql p) + => p ft -> p ft -> p (Maybe Bool) +(.>.) = compareBinOp (SQL..>.) + +-- | Compare operator corresponding SQL />=/ . +(.>=.) :: (SqlProjectable p, ProjectableShowSql p) + => p ft -> p ft -> p (Maybe Bool) +(.>=.) = compareBinOp (SQL..>=.) + +-- | Compare operator corresponding SQL /<>/ . +(.<>.) :: (SqlProjectable p, ProjectableShowSql p) + => p ft -> p ft -> p (Maybe Bool) +(.<>.) = compareBinOp (SQL..<>.) + +-- | Logical operator corresponding SQL /AND/ . +and' :: (SqlProjectable p, ProjectableShowSql p) + => p ft -> p ft -> p (Maybe Bool) +and' = compareBinOp SQL.and + +-- | Logical operator corresponding SQL /OR/ . +or' :: (SqlProjectable p, ProjectableShowSql p) + => p ft -> p ft -> p (Maybe Bool) +or' = compareBinOp SQL.or + +-- | Logical operator corresponding SQL /NOT/ . +not' :: (SqlProjectable p, ProjectableShowSql p) + => p (Maybe Bool) -> p (Maybe Bool) +not' = unsafeFlatUniOp SQL.NOT + +-- | Logical operator corresponding SQL /EXISTS/ . +exists :: (SqlProjectable p, ProjectableShowSql p) + => ListProjection (Projection Exists) r -> p (Maybe Bool) +exists = unsafeProjectSql . SQL.strUniOp (SQL.paren . SQL.defineUniOp SQL.EXISTS) + . unsafeShowSqlListProjection unsafeShowSql + +-- | Concatinate operator corresponding SQL /||/ . +(.||.) :: (SqlProjectable p, ProjectableShowSql p, IsString a) + => p a -> p a -> p a +(.||.) = unsafeBinOp (SQL..||.) + +-- | Concatinate operator corresponding SQL /||/ . Maybe type version. +(?||?) :: (SqlProjectable p, ProjectableShowSql p, IsString a) + => p (Maybe a) -> p (Maybe a) -> p (Maybe a) +(?||?) = unsafeBinOp (SQL..||.) + +-- | Unsafely make number projection binary operator from SQL operator string. +monoBinOp' :: (SqlProjectable p, ProjectableShowSql p) + => Keyword -> p a -> p a -> p a +monoBinOp' = monoBinOp . SQL.defineBinOp + +-- | Number operator corresponding SQL /+/ . +(.+.) :: (SqlProjectable p, ProjectableShowSql p, Num a) + => p a -> p a -> p a +(.+.) = monoBinOp' "+" + +-- | Number operator corresponding SQL /-/ . +(.-.) :: (SqlProjectable p, ProjectableShowSql p, Num a) + => p a -> p a -> p a +(.-.) = monoBinOp' "-" + +-- | Number operator corresponding SQL /// . +(./.) :: (SqlProjectable p, ProjectableShowSql p, Num a) + => p a -> p a -> p a +(./.) = monoBinOp' "/" + +-- | Number operator corresponding SQL /*/ . +(.*.) :: (SqlProjectable p, ProjectableShowSql p, Num a) + => p a -> p a -> p a +(.*.) = monoBinOp' "*" + +-- | Number negate uni-operator corresponding SQL /-/. +negate' :: (SqlProjectable p, ProjectableShowSql p, Num a) + => p a -> p a +negate' = unsafeFlatUniOp $ SQL.word "-" + +unsafeCastProjectable :: (SqlProjectable p, ProjectableShowSql p) + => p a -> p b +unsafeCastProjectable = unsafeProjectSql . unsafeShowSql + +-- | Number fromIntegral uni-operator. +fromIntegral' :: (SqlProjectable p, ProjectableShowSql p, Integral a, Num b) + => p a -> p b +fromIntegral' = unsafeCastProjectable + +-- | Unsafely show number into string-like type in projections. +showNum :: (SqlProjectable p, ProjectableShowSql p, Num a, IsString b) + => p a -> p b +showNum = unsafeCastProjectable + +-- | Number operator corresponding SQL /+/ . +(?+?) :: (SqlProjectable p, ProjectableShowSql p, Num a) + => p (Maybe a) -> p (Maybe a) -> p (Maybe a) +(?+?) = monoBinOp' "+" + +-- | Number operator corresponding SQL /-/ . +(?-?) :: (SqlProjectable p, ProjectableShowSql p, Num a) + => p (Maybe a) -> p (Maybe a) -> p (Maybe a) +(?-?) = monoBinOp' "-" + +-- | Number operator corresponding SQL /// . +(?/?) :: (SqlProjectable p, ProjectableShowSql p, Num a) + => p (Maybe a) -> p (Maybe a) -> p (Maybe a) +(?/?) = monoBinOp' "/" + +-- | Number operator corresponding SQL /*/ . +(?*?) :: (SqlProjectable p, ProjectableShowSql p, Num a) + => p (Maybe a) -> p (Maybe a) -> p (Maybe a) +(?*?) = monoBinOp' "*" + +-- | Number negate uni-operator corresponding SQL /-/. +negateMaybe :: (SqlProjectable p, ProjectableShowSql p, Num a) + => p (Maybe a) -> p (Maybe a) +negateMaybe = unsafeFlatUniOp $ SQL.word "-" + +-- | Number fromIntegral uni-operator. +fromIntegralMaybe :: (SqlProjectable p, ProjectableShowSql p, Integral a, Num b) + => p (Maybe a) -> p (Maybe b) +fromIntegralMaybe = unsafeCastProjectable + +-- | Unsafely show number into string-like type in projections. +showNumMaybe :: (SqlProjectable p, ProjectableShowSql p, Num a, IsString b) + => p (Maybe a) -> p (Maybe b) +showNumMaybe = unsafeCastProjectable + +unsafeSqlWord :: ProjectableShowSql p => p a -> Keyword +unsafeSqlWord = SQL.word . unsafeShowSql + +whensClause :: (SqlProjectable p, ProjectableShowSql p) + => String -- ^ Error tag + -> [(p a, p b)] -- ^ Each when clauses + -> p b -- ^ Else result projection + -> Keyword -- ^ Result projection +whensClause eTag cs0 e = d cs0 where + d [] = error $ eTag ++ ": Empty when clauses!" + d cs@(_:_) = mconcat [when' p r | (p, r) <- cs] <> else' <> SQL.END + when' p r = SQL.WHEN <> unsafeSqlWord p <> SQL.THEN <> unsafeSqlWord r + else' = SQL.ELSE <> unsafeSqlWord e + +-- | Search case operator correnponding SQL search /CASE/. +-- Like, /CASE WHEN p0 THEN a WHEN p1 THEN b ... ELSE c END/ +caseSearch :: (SqlProjectable p, ProjectableShowSql p) + => [(p (Maybe Bool), p a)] -- ^ Each when clauses + -> p a -- ^ Else result projection + -> p a -- ^ Result projection +caseSearch cs e = unsafeProjectSql . SQL.wordShow $ SQL.CASE <> whensClause "caseSearch" cs e + +-- | Same as 'caseSearch', but you can write like `casesOrElse` . +casesOrElse :: (SqlProjectable p, ProjectableShowSql p) + => [(p (Maybe Bool), p a)] -- ^ Each when clauses + -> p a -- ^ Else result projection + -> p a -- ^ Result projection +casesOrElse = caseSearch + +-- | Null default version of 'caseSearch'. +caseSearchMaybe :: (ProjectableShowSql p, SqlProjectable p) + => [(p (Maybe Bool), p (Maybe a))] -- ^ Each when clauses + -> p (Maybe a) -- ^ Result projection +caseSearchMaybe cs = caseSearch cs unsafeValueNull + +-- | Simple case operator correnponding SQL simple /CASE/. +-- Like, /CASE x WHEN v THEN a WHEN w THEN b ... ELSE c END/ +case' :: (SqlProjectable p, ProjectableShowSql p) + => p a -- ^ Projection value to match + -> [(p a, p b)] -- ^ Each when clauses + -> p b -- ^ Else result projection + -> p b -- ^ Result projection +case' v cs e = unsafeProjectSql . SQL.wordShow $ SQL.CASE <> unsafeSqlWord v <> whensClause "case'" cs e + +-- | Uncurry version of 'case'', and you can write like ... `casesOrElse'` . +casesOrElse' :: (SqlProjectable p, ProjectableShowSql p) + => (p a, [(p a, p b)]) -- ^ Projection value to match and each when clauses list + -> p b -- ^ Else result projection + -> p b -- ^ Result projection +casesOrElse' = uncurry case' + +-- | Null default version of 'case''. +caseMaybe :: (SqlProjectable p, ProjectableShowSql p, ProjectableMaybe p) + => p a -- ^ Projection value to match + -> [(p a, p (Maybe b))] -- ^ Each when clauses + -> p (Maybe b) -- ^ Result projection +caseMaybe v cs = case' v cs unsafeValueNull + +-- | Binary operator corresponding SQL /IN/ . +in' :: (SqlProjectable p, ProjectableShowSql p) + => p t -> ListProjection p t -> p (Maybe Bool) +in' a lp = unsafeProjectSql + $ parenBinStr SQL.in' (unsafeShowSql a) (unsafeShowSqlListProjection unsafeShowSql lp) + +-- | Operator corresponding SQL /IS NULL/ , and extended against record types. +isNothing :: (SqlProjectable (Projection c), ProjectableShowSql (Projection c), HasColumnConstraint NotNull r) + => Projection c (Maybe r) -> Projection c (Maybe Bool) +isNothing mr = unsafeProjectSql $ + parenBinStr (SQL.defineBinOp SQL.IS) + (Projection.unsafeShowSqlNotNullMaybeProjection mr) (SQL.wordShow SQL.NULL) + +-- | Operator corresponding SQL /NOT (... IS NULL)/ , and extended against record type. +isJust :: (SqlProjectable (Projection c), ProjectableShowSql (Projection c), HasColumnConstraint NotNull r) + => Projection c (Maybe r) -> Projection c (Maybe Bool) +isJust = not' . isNothing + +-- | Operator from maybe type using record extended 'isNull'. +fromMaybe' :: (SqlProjectable (Projection c), ProjectableShowSql (Projection c), HasColumnConstraint NotNull r) + => Projection c r -> Projection c (Maybe r) -> Projection c r +fromMaybe' d p = [ (isNothing p, d) ] `casesOrElse` unsafeCastProjectable p + +unsafeUniTermFunction :: SqlProjectable p => Keyword -> p t +unsafeUniTermFunction = unsafeProjectSql . (++ "()") . SQL.wordShow + +-- | /RANK()/ term. +rank :: Projection OverWindow Int64 +rank = unsafeUniTermFunction SQL.RANK + +-- | /DENSE_RANK()/ term. +denseRank :: Projection OverWindow Int64 +denseRank = unsafeUniTermFunction SQL.DENSE_RANK + +-- | /DENSE_RANK()/ term. +dense_rank :: Projection OverWindow Int64 +dense_rank = denseRank +{-# DEPRECATED dense_rank "Use denseRank instead of this." #-} + +-- | /ROW_NUMBER()/ term. +rowNumber :: Projection OverWindow Int64 +rowNumber = unsafeUniTermFunction SQL.ROW_NUMBER + +-- | /ROW_NUMBER()/ term. +row_number :: Projection OverWindow Int64 +row_number = rowNumber +{-# DEPRECATED row_number "Use rowNumber instead of this." #-} + +-- | /PERCENT_RANK()/ term. +percentRank :: Projection OverWindow Double +percentRank = unsafeUniTermFunction SQL.PERCENT_RANK + +-- | /PERCENT_RANK()/ term. +percent_rank :: Projection OverWindow Double +percent_rank = percentRank +{-# DEPRECATED percent_rank "Use percentRank instead of this." #-} + +-- | /CUME_DIST()/ term. +cumeDist :: Projection OverWindow Double +cumeDist = unsafeUniTermFunction SQL.CUME_DIST + +-- | /CUME_DIST()/ term. +cume_dist :: Projection OverWindow Double +cume_dist = cumeDist +{-# DEPRECATED cume_dist "Use cumeDist instead of this." #-} + +-- | Placeholder parameter type which has real parameter type arguemnt 'p'. +data PlaceHolders p = PlaceHolders + +-- | Unsafely add placeholder parameter to queries. +addPlaceHolders :: Functor f => f a -> f (PlaceHolders p, a) +addPlaceHolders = fmap ((,) PlaceHolders) + +-- | Unsafely get placeholder parameter +unsafePlaceHolders :: PlaceHolders p +unsafePlaceHolders = PlaceHolders + +-- | Unsafely cast placeholder parameter type. +unsafeCastPlaceHolders :: PlaceHolders a -> PlaceHolders b +unsafeCastPlaceHolders PlaceHolders = PlaceHolders + +unsafeProjectPlaceHolder' :: (PersistableWidth r, SqlProjectable p) + => (PersistableRecordWidth r, p r) +unsafeProjectPlaceHolder' = unsafeProjectSqlTerms . (`replicate` "?") <$> derivedWidth + +unsafeProjectPlaceHolder :: (PersistableWidth r, SqlProjectable p) + => p r +unsafeProjectPlaceHolder = snd unsafeProjectPlaceHolder' + +-- | Provide scoped placeholder and return its parameter object. +placeholder' :: (PersistableWidth t, SqlProjectable p) => (p t -> a) -> (PlaceHolders t, a) +placeholder' f = (PlaceHolders, f unsafeProjectPlaceHolder) + +-- | Provide scoped placeholder and return its parameter object. Monadic version. +placeholder :: (PersistableWidth t, SqlProjectable p, Monad m) => (p t -> m a) -> m (PlaceHolders t, a) +placeholder f = do + let (ph, ma) = placeholder' f + a <- ma + return (ph, a) + + +-- | Zipping projections. +projectZip :: ProjectableApplicative p => p a -> p b -> p (a, b) +projectZip pa pb = (,) |$| pa |*| pb + +-- | Binary operator the same as 'projectZip'. +(><) :: ProjectableApplicative p => p a -> p b -> p (a, b) +(><) = projectZip + +-- | Interface to control 'Maybe' of phantom type in projections. +class ProjectableMaybe p where + -- | Cast projection phantom type into 'Maybe'. + just :: p a -> p (Maybe a) + -- | Compose nested 'Maybe' phantom type on projection. + flattenMaybe :: p (Maybe (Maybe a)) -> p (Maybe a) + +-- | Control phantom 'Maybe' type in placeholder parameters. +instance ProjectableMaybe PlaceHolders where + just = unsafeCastPlaceHolders + flattenMaybe = unsafeCastPlaceHolders + +-- | Control phantom 'Maybe' type in projection type 'Projection'. +instance ProjectableMaybe (Projection c) where + just = Projection.just + flattenMaybe = Projection.flattenMaybe + +-- | Control phantom 'Maybe' type in SQL expression type 'Expr'. +instance ProjectableMaybe (Expr p) where + just = Expr.just + flattenMaybe = Expr.fromJust + +-- | Zipping except for identity element laws. +class ProjectableApplicative p => ProjectableIdZip p where + leftId :: p ((), a) -> p a + rightId :: p (a, ()) -> p a + +-- | Zipping except for identity element laws against placeholder parameter type. +instance ProjectableIdZip PlaceHolders where + leftId = unsafeCastPlaceHolders + rightId = unsafeCastPlaceHolders + +-- | Weaken functor on projections. +class ProjectableFunctor p where + -- | Method like 'fmap'. + (|$|) :: ProductConstructor (a -> b) => (a -> b) -> p a -> p b + +-- | Same as '|$|' other than using infered record constructor. +ipfmap :: (ProjectableFunctor p, ProductConstructor (a -> b)) + => p a -> p b +ipfmap = (|$|) productConstructor + +-- | Weaken applicative functor on projections. +class ProjectableFunctor p => ProjectableApplicative p where + -- | Method like '<*>'. + (|*|) :: p (a -> b) -> p a -> p b + +-- | Compose seed of record type 'PlaceHolders'. +instance ProjectableFunctor PlaceHolders where + _ |$| PlaceHolders = PlaceHolders + +-- | Compose record type 'PlaceHolders' using applicative style. +instance ProjectableApplicative PlaceHolders where + pf |*| pa = unsafeCastPlaceHolders (pf >< pa) + +-- | Compose seed of record type 'Projection'. +instance ProjectableFunctor (Projection c) where + (|$|) = Projection.pfmap + +-- | Compose record type 'Projection' using applicative style. +instance ProjectableApplicative (Projection c) where + (|*|) = Projection.pap + +-- | Compose seed of projection path 'Pi' which has record result type. +instance ProjectableFunctor (Pi a) where + (|$|) = Pi.pfmap + +-- | Compose projection path 'Pi' which has record result type using applicative style. +instance ProjectableApplicative (Pi a) where + (|*|) = Pi.pap + +infixl 7 .*., ./., ?*?, ?/? +infixl 6 .+., .-., ?+?, ?-? +infixl 5 .||., ?||? +infixl 4 |$|, |*| +infix 4 .=., .<>., .>., .>=., .<., .<=., `in'` +infixr 3 `and'` +infixr 2 `or'` +infixl 1 >< diff --git a/src/Database/Relational/Query/ProjectableExtended.hs b/src/Database/Relational/Query/ProjectableExtended.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Query/ProjectableExtended.hs @@ -0,0 +1,254 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} + +-- | +-- Module : Database.Relational.Query.ProjectableExtended +-- Copyright : 2013 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module defines operators on various polymorphic projections +-- which needs extended GHC features. +module Database.Relational.Query.ProjectableExtended ( + -- * Projection for nested 'Maybe's + ProjectableFlattenMaybe (flatten), + + flattenPiMaybe, + + -- * Get narrower projections + (!), (?!), (?!?), (!??), + + (.!), (.?), + + -- * Aggregate functions + unsafeAggregateOp, + count, + sum', sumMaybe, avg, avgMaybe, + max', maxMaybe, min', minMaybe, + every, any', some', + + -- * Zipping projection type trick + ProjectableIdZip (leftId, rightId), + ProjectableRunIdsZip (runIds), flattenPh + -- generalizedZip', (>?<) + ) where + +import Prelude hiding (pi) +import Data.Int (Int64) +import Data.Monoid ((<>)) + +import qualified Language.SQL.Keyword as SQL + +import Database.Relational.Query.Context (Flat, Aggregated, OverWindow) +import Database.Relational.Query.Expr (Expr, fromJust) +import Database.Relational.Query.Projection (Projection) +import qualified Database.Relational.Query.Projection as Projection +import Database.Relational.Query.Projectable + (expr, PlaceHolders, unsafeUniOp, + ProjectableMaybe (flattenMaybe), ProjectableIdZip (leftId, rightId), + SqlProjectable) +import Database.Relational.Query.Pi (Pi) + + +-- | Projection interface. +class Projectable p0 p1 where + -- ｜ Project from projection type 'p0' into weaken projection types 'p1'. + project :: p0 c a -> p1 c a + + +class AggregatedContext ac +instance AggregatedContext Aggregated +instance AggregatedContext OverWindow + +-- | Unsafely make aggregation uni-operator from SQL keyword. +unsafeAggregateOp :: (AggregatedContext ac, SqlProjectable (p ac)) + => SQL.Keyword -> Projection Flat a -> p ac b +unsafeAggregateOp op = unsafeUniOp ((op <>) . SQL.paren) + +-- | Aggregation function COUNT. +count :: (AggregatedContext ac, SqlProjectable (p ac)) + => Projection Flat a -> p ac Int64 +count = unsafeAggregateOp SQL.COUNT + +-- | Aggregation function SUM. +sumMaybe :: (Num a, AggregatedContext ac, SqlProjectable (p ac)) + => Projection Flat (Maybe a) -> p ac (Maybe a) +sumMaybe = unsafeAggregateOp SQL.SUM + +-- | Aggregation function SUM. +sum' :: (Num a, AggregatedContext ac, SqlProjectable (p ac)) + => Projection Flat a -> p ac (Maybe a) +sum' = sumMaybe . Projection.just + +-- | Aggregation function AVG. +avgMaybe :: (Num a, Fractional b, AggregatedContext ac, SqlProjectable (p ac)) + => Projection Flat (Maybe a) -> p ac (Maybe b) +avgMaybe = unsafeAggregateOp SQL.AVG + +-- | Aggregation function AVG. +avg :: (Num a, Fractional b, AggregatedContext ac, SqlProjectable (p ac)) + => Projection Flat a -> p ac (Maybe b) +avg = avgMaybe . Projection.just + +-- | Aggregation function MAX. +maxMaybe :: (Ord a, AggregatedContext ac, SqlProjectable (p ac)) + => Projection Flat (Maybe a) -> p ac (Maybe a) +maxMaybe = unsafeAggregateOp SQL.MAX + +-- | Aggregation function MAX. +max' :: (Ord a, AggregatedContext ac, SqlProjectable (p ac)) + => Projection Flat a -> p ac (Maybe a) +max' = maxMaybe . Projection.just + +-- | Aggregation function MIN. +minMaybe :: (Ord a, AggregatedContext ac, SqlProjectable (p ac)) + => Projection Flat (Maybe a) -> p ac (Maybe a) +minMaybe = unsafeAggregateOp SQL.MIN + +-- | Aggregation function MIN. +min' :: (Ord a, AggregatedContext ac, SqlProjectable (p ac)) + => Projection Flat a -> p ac (Maybe a) +min' = minMaybe . Projection.just + +-- | Aggregation function EVERY. +every :: (AggregatedContext ac, SqlProjectable (p ac)) + => Projection Flat (Maybe Bool) -> p ac (Maybe Bool) +every = unsafeAggregateOp SQL.EVERY + +-- | Aggregation function ANY. +any' :: (AggregatedContext ac, SqlProjectable (p ac)) + => Projection Flat (Maybe Bool) -> p ac (Maybe Bool) +any' = unsafeAggregateOp SQL.ANY + +-- | Aggregation function SOME. +some' :: (AggregatedContext ac, SqlProjectable (p ac)) + => Projection Flat (Maybe Bool) -> p ac (Maybe Bool) +some' = unsafeAggregateOp SQL.SOME + +-- | Project from 'Projection' into 'Projection'. +instance Projectable Projection Projection where + project = id + +-- | Project from 'Projection' into 'Expr' 'Projection'. +instance Projectable Projection Expr where + project = expr + +projectPi :: Projectable Projection p1 => Projection c a -> Pi a b -> p1 c b +projectPi p = project . Projection.pi p + +projectPiMaybe :: Projectable Projection p1 => Projection c (Maybe a) -> Pi a b -> p1 c (Maybe b) +projectPiMaybe p = project . Projection.piMaybe p + +projectPiMaybe' :: Projectable Projection p1 => Projection c (Maybe a) -> Pi a (Maybe b) -> p1 c (Maybe b) +projectPiMaybe' p = project . Projection.piMaybe' p + +-- | Get narrower projection along with projection path +-- and project into result projection type. +(!) :: Projectable Projection p + => Projection c a -- ^ Source projection + -> Pi a b -- ^ Projection path + -> p c b -- ^ Narrower projected object +(!) = projectPi + +-- | Get narrower projection along with projection path +-- and project into result projection type. +-- 'Maybe' phantom type is propagated. +(?!) :: Projectable Projection p + => Projection c (Maybe a) -- ^ Source 'Projection'. 'Maybe' type + -> Pi a b -- ^ Projection path + -> p c (Maybe b) -- ^ Narrower projected object. 'Maybe' type result +(?!) = projectPiMaybe + +-- | Get narrower projection along with projection path +-- and project into result projection type. +-- 'Maybe' phantom type is propagated. Projection path leaf is 'Maybe' case. +(?!?) :: Projectable Projection p + => Projection c (Maybe a) -- ^ Source 'Projection'. 'Maybe' phantom type + -> Pi a (Maybe b) -- ^ Projection path. 'Maybe' type leaf + -> p c (Maybe b) -- ^ Narrower projected object. 'Maybe' phantom type result +(?!?) = projectPiMaybe' + +-- | Get narrower projected expression along with projectino path +-- and strip 'Maybe' phantom type off. +(.!) :: Projection c (Maybe a) -- ^ Source projection type 'p'. 'Maybe' phantom type + -> Pi a b -- ^ Projection path + -> Expr c b -- ^ Narrower projected expression. 'Maybe' phantom type is stripped off +(.!) p = fromJust . projectPiMaybe p + +-- | Get narrower projected expression along with projectino path +-- and strip 'Maybe' phantom type off. +-- Projection path leaf is 'Maybe' case. +(.?) :: Projection c (Maybe a) -- ^ Source projection type 'p'. 'Maybe' phantom type + -> Pi a (Maybe b) -- ^ Projection path. 'Maybe' type leaf + -> Expr c b -- ^ Narrower projected expression. 'Maybe' phantom type is stripped off +(.?) p = fromJust . projectPiMaybe' p + + +-- | Interface to compose phantom 'Maybe' nested type. +class ProjectableFlattenMaybe a b where + flatten :: ProjectableMaybe p => p a -> p b + +-- | Compose 'Maybe' type in projection phantom type. +instance ProjectableFlattenMaybe (Maybe a) b + => ProjectableFlattenMaybe (Maybe (Maybe a)) b where + flatten = flatten . flattenMaybe + +-- | Not 'Maybe' type is not processed. +instance ProjectableFlattenMaybe (Maybe a) (Maybe a) where + flatten = id + +-- | Get narrower projection with flatten leaf phantom Maybe types along with projection path. +flattenPiMaybe :: (ProjectableMaybe (Projection cont), ProjectableFlattenMaybe (Maybe b) c) + => Projection cont (Maybe a) -- ^ Source 'Projection'. 'Maybe' phantom type + -> Pi a b -- ^ Projection path + -> Projection cont c -- ^ Narrower 'Projection'. Flatten 'Maybe' phantom type +flattenPiMaybe p = flatten . Projection.piMaybe p + +projectFlattenPiMaybe :: (ProjectableMaybe (Projection cont), + Projectable Projection p1, ProjectableFlattenMaybe (Maybe b) c) + => Projection cont (Maybe a) -- ^ Source 'Projection'. 'Maybe' phantom type + -> Pi a b -- ^ Projection path + -> p1 cont c -- ^ Narrower 'Projection'. Flatten 'Maybe' phantom type +projectFlattenPiMaybe p = project . flattenPiMaybe p + +-- | Get narrower projection with flatten leaf phantom Maybe types along with projection path +-- and project into result projection type. +(!??) :: (ProjectableFlattenMaybe (Maybe b) c, + Projectable Projection p, ProjectableMaybe (p cont)) + => Projection cont (Maybe a) -- ^ Source 'Projection'. 'Maybe' phantom type + -> Pi a b -- ^ Projection path + -> p cont c -- ^ Narrower flatten and projected object. +(!??) = projectFlattenPiMaybe + + +-- | Interface to run recursively identity element laws. +class ProjectableRunIdsZip a b where + runIds :: ProjectableIdZip p => p a -> p b + +-- | Run left identity element law. +instance ProjectableRunIdsZip a b => ProjectableRunIdsZip ((), a) b where + runIds = runIds . leftId + +-- | Run right identity element law. +instance ProjectableRunIdsZip a b => ProjectableRunIdsZip (a, ()) b where + runIds = runIds . rightId + +-- | Base case definition to run recursively identity element laws. +instance ProjectableRunIdsZip a a where + runIds = id + +-- | Specialize 'runIds' for 'PlaceHolders' type. +flattenPh :: ProjectableRunIdsZip a b => PlaceHolders a -> PlaceHolders b +flattenPh = runIds + +-- -- | Binary operator the same as 'generalizedZip'. +-- (>?<) :: (ProjectableIdZip p, ProjectableRunIdsZip (a, b) c) +-- => p a -> p b -> p c +-- (>?<) = generalizedZip' + +infixl 8 !, ?!, ?!?, !??, .!, .? +-- infixl 1 >?< diff --git a/src/Database/Relational/Query/Projection.hs b/src/Database/Relational/Query/Projection.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Query/Projection.hs @@ -0,0 +1,184 @@ +{-# LANGUAGE FlexibleContexts #-} + +-- | +-- Module : Database.Relational.Query.Projection +-- Copyright : 2013 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module defines query projection type structure and interfaces. +module Database.Relational.Query.Projection ( + -- * Projection data structure and interface + Projection, + + width, + columns, + untype, + + unsafeFromColumns, + unsafeFromQualifiedSubQuery, + unsafeFromTable, + + -- * Projections + pi, piMaybe, piMaybe', + + flattenMaybe, just, + + unsafeToAggregated, unsafeToFlat, unsafeChangeContext, + unsafeShowSqlNotNullMaybeProjection, + + pfmap, pap, + + -- * List Projection + ListProjection, list, unsafeListProjectionFromSubQuery, + unsafeShowSqlListProjection + ) where + +import Prelude hiding (pi) + +import qualified Language.SQL.Keyword as SQL + +import Database.Record (HasColumnConstraint, NotNull, NotNullColumnConstraint) +import qualified Database.Record.KeyConstraint as KeyConstraint + +import Database.Relational.Query.Internal.SQL (rowListStringString) +import Database.Relational.Query.Context (Aggregated, Flat) +import Database.Relational.Query.Component (ColumnSQL) +import Database.Relational.Query.Table (Table) +import qualified Database.Relational.Query.Table as Table +import Database.Relational.Query.Pure (ProductConstructor (..)) +import Database.Relational.Query.Pi (Pi) +import qualified Database.Relational.Query.Pi.Unsafe as UnsafePi +import Database.Relational.Query.Sub + (SubQuery, Qualified, ProjectionUnit, + UntypedProjection, widthOfUntypedProjection, columnsOfUntypedProjection, + untypedProjectionFromColumns, untypedProjectionFromSubQuery) +import qualified Database.Relational.Query.Sub as SubQuery + + +-- | Phantom typed projection. Projected into Haskell record type 't'. +newtype Projection c t = Projection { untypeProjection :: UntypedProjection } + +typedProjection :: UntypedProjection -> Projection c t +typedProjection = Projection + +units :: Projection c t -> [ProjectionUnit] +units = untypeProjection + +fromUnits :: [ProjectionUnit] -> Projection c t +fromUnits = typedProjection + +-- | Width of 'Projection'. +width :: Projection c r -> Int +width = widthOfUntypedProjection . untypeProjection + +-- | Get column SQL string list of projection. +columns :: Projection c r -- ^ Source 'Projection' + -> [ColumnSQL] -- ^ Result SQL string list +columns = columnsOfUntypedProjection . untypeProjection + +-- | Unsafely get untyped projection. +untype :: Projection c r -> UntypedProjection +untype = untypeProjection + + +-- | Unsafely generate 'Projection' from SQL string list. +unsafeFromColumns :: [ColumnSQL] -- ^ SQL string list specifies columns + -> Projection c r -- ^ Result 'Projection' +unsafeFromColumns = typedProjection . untypedProjectionFromColumns + +-- | Unsafely generate 'Projection' from qualified subquery. +unsafeFromQualifiedSubQuery :: Qualified SubQuery -> Projection c t +unsafeFromQualifiedSubQuery = typedProjection . untypedProjectionFromSubQuery + +-- | Unsafely generate unqualified 'Projection' from 'Table'. +unsafeFromTable :: Table r + -> Projection c r +unsafeFromTable = unsafeFromColumns . Table.columns + + +-- | Unsafely trace projection path. +unsafeProject :: Projection c a' -> Pi a b -> Projection c b' +unsafeProject p pi' = + unsafeFromColumns + . (`UnsafePi.pi` pi') + . columns $ p + +-- | Trace projection path to get narrower 'Projection'. +pi :: Projection c a -- ^ Source 'Projection' + -> Pi a b -- ^ Projection path + -> Projection c b -- ^ Narrower 'Projection' +pi = unsafeProject + +-- | Trace projection path to get narrower 'Projection'. From 'Maybe' type to 'Maybe' type. +piMaybe :: Projection c (Maybe a) -- ^ Source 'Projection'. 'Maybe' type + -> Pi a b -- ^ Projection path + -> Projection c (Maybe b) -- ^ Narrower 'Projection'. 'Maybe' type result +piMaybe = unsafeProject + +-- | Trace projection path to get narrower 'Projection'. From 'Maybe' type to 'Maybe' type. +-- Leaf type of projection path is 'Maybe'. +piMaybe' :: Projection c (Maybe a) -- ^ Source 'Projection'. 'Maybe' type + -> Pi a (Maybe b) -- ^ Projection path. 'Maybe' type leaf + -> Projection c (Maybe b) -- ^ Narrower 'Projection'. 'Maybe' type result +piMaybe' = unsafeProject + +unsafeCast :: Projection c r -> Projection c r' +unsafeCast = typedProjection . untypeProjection + +-- | Composite nested 'Maybe' on projection phantom type. +flattenMaybe :: Projection c (Maybe (Maybe a)) -> Projection c (Maybe a) +flattenMaybe = unsafeCast + +-- | Cast into 'Maybe' on projection phantom type. +just :: Projection c r -> Projection c (Maybe r) +just = unsafeCast + +-- | Unsafely cast context type tag. +unsafeChangeContext :: Projection c r -> Projection c' r +unsafeChangeContext = typedProjection . untypeProjection + +-- | Unsafely lift to aggregated context. +unsafeToAggregated :: Projection Flat r -> Projection Aggregated r +unsafeToAggregated = unsafeChangeContext + +-- | Unsafely down to flat context. +unsafeToFlat :: Projection Aggregated r -> Projection Flat r +unsafeToFlat = unsafeChangeContext + +notNullMaybeConstraint :: HasColumnConstraint NotNull r => Projection c (Maybe r) -> NotNullColumnConstraint r +notNullMaybeConstraint = const KeyConstraint.columnConstraint + +-- | Unsafely get SQL string expression of not null key projection. +unsafeShowSqlNotNullMaybeProjection :: HasColumnConstraint NotNull r => Projection c (Maybe r) -> String +unsafeShowSqlNotNullMaybeProjection p = show . (!! KeyConstraint.index (notNullMaybeConstraint p)) . columns $ p + +-- | Projectable fmap of 'Projection' type. +pfmap :: ProductConstructor (a -> b) + => (a -> b) -> Projection c a -> Projection c b +_ `pfmap` p = unsafeCast p + +-- | Projectable ap of 'Projection' type. +pap :: Projection c (a -> b) -> Projection c a -> Projection c b +pf `pap` pa = fromUnits $ units pf ++ units pa + +-- | Projection type for row list. +data ListProjection p t = List [p t] + | Sub SubQuery + +-- | Make row list projection from 'Projection' list. +list :: [p t] -> ListProjection p t +list = List + +-- | Make row list projection from 'SubQuery'. +unsafeListProjectionFromSubQuery :: SubQuery -> ListProjection p t +unsafeListProjectionFromSubQuery = Sub + +-- | Map projection show operatoions and concatinate to single SQL expression. +unsafeShowSqlListProjection :: (p t -> String) -> ListProjection p t -> String +unsafeShowSqlListProjection sf = d where + d (List ps) = rowListStringString $ map sf ps + d (Sub sub) = SQL.wordShow . SQL.paren $ SubQuery.showSQL sub diff --git a/src/Database/Relational/Query/Pure.hs b/src/Database/Relational/Query/Pure.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Query/Pure.hs @@ -0,0 +1,162 @@ +{-# LANGUAGE FlexibleInstances #-} + +-- | +-- Module : Database.Relational.Query.Pure +-- Copyright : 2013 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module defines interfaces between haskell pure values +-- and query internal projection values. +module Database.Relational.Query.Pure ( + + -- * Interface to specify record constructors. + ProductConstructor (..), + + -- * Constant SQL Terms + ShowConstantTermsSQL (..) + ) where + +import Data.Monoid (mconcat) +import Data.Int (Int16, Int32, Int64) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy as LB +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.Lazy as LT +import Text.Printf (PrintfArg, printf) +import Data.Time (FormatTime, Day, TimeOfDay, LocalTime, formatTime) +import System.Locale (defaultTimeLocale) + +import Language.SQL.Keyword (Keyword (..), wordShow) +import Database.Record + (PersistableWidth, persistableWidth, PersistableRecordWidth) +import Database.Record.Persistable + (runPersistableRecordWidth) + + +-- | Specify tuple like record constructors which are allowed to define 'ProjectableFunctor'. +class ProductConstructor r where + -- | The constructor which has type 'r'. + productConstructor :: r + +-- | ProductConstructor instance of pair. +instance ProductConstructor (a -> b -> (a, b)) where + productConstructor = (,) + + +-- | Constant integral SQL expression. +intExprSQL :: (Show a, Integral a) => a -> String +intExprSQL = show + +intTermsSQL :: (Show a, Integral a) => a -> [String] +intTermsSQL = (:[]) . intExprSQL + +-- | Escape 'String' for constant SQL string expression. +escapeStringToSqlExpr :: String -> String +escapeStringToSqlExpr = rec where + rec "" = "" + rec ('\'':cs) = '\'' : '\'' : rec cs + rec (c:cs) = c : rec cs + +-- | From 'String' into constant SQL string expression. +stringExprSQL :: String -> String +stringExprSQL = ('\'':) . (++ "'") . escapeStringToSqlExpr + +stringTermsSQL :: String -> [String] +stringTermsSQL = (:[]) . stringExprSQL + +-- | Interface for constant SQL term list. +class ShowConstantTermsSQL a where + showConstantTermsSQL :: a -> [String] + +-- | Constant SQL terms of 'Int16'. +instance ShowConstantTermsSQL Int16 where + showConstantTermsSQL = intTermsSQL + +-- | Constant SQL terms of 'Int32'. +instance ShowConstantTermsSQL Int32 where + showConstantTermsSQL = intTermsSQL + +-- | Constant SQL terms of 'Int64'. +instance ShowConstantTermsSQL Int64 where + showConstantTermsSQL = intTermsSQL + +-- | Constant SQL terms of 'String'. +instance ShowConstantTermsSQL String where + showConstantTermsSQL = stringTermsSQL + +-- | Constant SQL terms of 'ByteString'. +instance ShowConstantTermsSQL ByteString where + showConstantTermsSQL = stringTermsSQL . T.unpack . T.decodeUtf8 + +-- | Constant SQL terms of 'LB.ByteString'. +instance ShowConstantTermsSQL LB.ByteString where + showConstantTermsSQL = showConstantTermsSQL . mconcat . LB.toChunks + +-- | Constant SQL terms of 'Text'. +instance ShowConstantTermsSQL Text where + showConstantTermsSQL = stringTermsSQL . T.unpack + +-- | Constant SQL terms of 'LT.Text'. +instance ShowConstantTermsSQL LT.Text where + showConstantTermsSQL = showConstantTermsSQL . LT.toStrict + +-- | Constant SQL terms of 'Char'. +instance ShowConstantTermsSQL Char where + showConstantTermsSQL = stringTermsSQL . (:"") + +-- | Constant SQL terms of 'Bool'. +instance ShowConstantTermsSQL Bool where + showConstantTermsSQL = (:[]) . d where + d True = "(0=0)" + d False = "(0=1)" + +floatTerms :: (PrintfArg a, Ord a, Num a)=> a -> [String] +floatTerms f = (:[]) $ printf fmt f where + fmt + | f >= 0 = "%f" + | otherwise = "(%f)" + +-- | Constant SQL terms of 'Float'. Caution for floating-point error rate. +instance ShowConstantTermsSQL Float where + showConstantTermsSQL = floatTerms + +-- | Constant SQL terms of 'Double'. Caution for floating-point error rate. +instance ShowConstantTermsSQL Double where + showConstantTermsSQL = floatTerms + +constantTimeTerms :: FormatTime t => Keyword -> String -> t -> [String] +constantTimeTerms kw fmt t = [unwords [wordShow kw, + stringExprSQL $ formatTime defaultTimeLocale fmt t]] + +-- | Constant SQL terms of 'Day'. +instance ShowConstantTermsSQL Day where + showConstantTermsSQL = constantTimeTerms DATE "%Y-%m-%d" + +-- | Constant SQL terms of 'TimeOfDay'. +instance ShowConstantTermsSQL TimeOfDay where + showConstantTermsSQL = constantTimeTerms TIME "%H:%M:%S" + +-- | Constant SQL terms of 'LocalTime'. +instance ShowConstantTermsSQL LocalTime where + showConstantTermsSQL = constantTimeTerms TIMESTAMP "%Y-%m-%d %H:%M:%S" + +showMaybeTerms :: ShowConstantTermsSQL a => PersistableRecordWidth a -> Maybe a -> [String] +showMaybeTerms wa = d where + d (Just a) = showConstantTermsSQL a + d Nothing = replicate (runPersistableRecordWidth wa) "NULL" + +-- | Constant SQL terms of 'Maybe' type. Width inference is required. +instance (PersistableWidth a, ShowConstantTermsSQL a) + => ShowConstantTermsSQL (Maybe a) where + showConstantTermsSQL = showMaybeTerms persistableWidth + +-- | Constant SQL terms of '(a, b)' type. +instance (ShowConstantTermsSQL a, ShowConstantTermsSQL b) + => ShowConstantTermsSQL (a, b) where + showConstantTermsSQL (a, b) = showConstantTermsSQL a ++ showConstantTermsSQL b diff --git a/src/Database/Relational/Query/Relation.hs b/src/Database/Relational/Query/Relation.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Query/Relation.hs @@ -0,0 +1,443 @@ +{-# LANGUAGE FlexibleContexts #-} + +-- | +-- Module : Database.Relational.Query.Relation +-- Copyright : 2013 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module defines re-usable Relation type +-- to compose complex query. +module Database.Relational.Query.Relation ( + -- * Relation type + Relation, + + table, derivedRelation, tableOf, + relation, relation', + aggregateRelation, aggregateRelation', + + UniqueRelation, + unsafeUnique, unUnique, + + uniqueRelation', aggregatedUnique, + + dump, + + sqlFromRelationWith, sqlFromRelation, + + -- * Query using relation + query, query', queryMaybe, queryMaybe', queryList, queryList', queryScalar, queryScalar', + uniqueQuery', uniqueQueryMaybe', + + -- * Direct style join + JoinRestriction, + rightPh, leftPh, + inner', left', right', full', + inner, left, right, full, + on', + + -- * Relation append + union, except, intersect, + unionAll, exceptAll, intersectAll, + + union', except', intersect', + unionAll', exceptAll', intersectAll', + ) where + +import Control.Applicative ((<$>)) + +import Database.Relational.Query.Context (Flat, Aggregated) +import Database.Relational.Query.Monad.Type (ConfigureQuery, configureQuery, qualifyQuery) +import Database.Relational.Query.Monad.Class + (MonadQualify (liftQualify), MonadQualifyUnique (liftQualifyUnique), MonadQuery (unsafeSubQuery), on) +import Database.Relational.Query.Monad.Simple (QuerySimple, SimpleQuery) +import qualified Database.Relational.Query.Monad.Simple as Simple +import Database.Relational.Query.Monad.Aggregate (QueryAggregate, AggregatedQuery) +import qualified Database.Relational.Query.Monad.Aggregate as Aggregate +import Database.Relational.Query.Monad.Unique (QueryUnique) +import qualified Database.Relational.Query.Monad.Unique as Unique + +import Database.Relational.Query.Component (columnSQL, Config, defaultConfig, Duplication (Distinct, All)) +import Database.Relational.Query.Table (Table, TableDerivable, derivedTable) +import Database.Relational.Query.Internal.SQL (StringSQL, showStringSQL) +import Database.Relational.Query.Internal.Product (NodeAttr(Just', Maybe)) +import Database.Relational.Query.Sub (SubQuery) +import qualified Database.Relational.Query.Sub as SubQuery + +import Database.Relational.Query.Scalar (ScalarDegree) +import Database.Relational.Query.Pi (Pi) +import Database.Relational.Query.Projection + (Projection, ListProjection, unsafeListProjectionFromSubQuery) +import qualified Database.Relational.Query.Projection as Projection +import Database.Relational.Query.Projectable + (PlaceHolders, addPlaceHolders, unsafePlaceHolders, projectZip) +import Database.Relational.Query.ProjectableExtended ((!)) + + +-- | Relation type with place-holder parameter 'p' and query result type 'r'. +newtype Relation p r = SubQuery (ConfigureQuery SubQuery) + + +-- | Simple 'Relation' from 'Table'. +table :: Table r -> Relation () r +table = SubQuery . return . SubQuery.fromTable + +-- | Infered 'Relation'. +derivedRelation :: TableDerivable r => Relation () r +derivedRelation = table derivedTable + +-- | Interface to derive 'Table' type object. +tableOf :: TableDerivable r => Relation () r -> Table r +tableOf = const derivedTable + +placeHoldersFromRelation :: Relation p r -> PlaceHolders p +placeHoldersFromRelation = const unsafePlaceHolders + +-- | Sub-query Qualify monad from relation. +subQueryQualifyFromRelation :: Relation p r -> ConfigureQuery SubQuery +subQueryQualifyFromRelation = d where + d (SubQuery qsub) = qsub + +-- -- | Sub-query from relation. +-- subQueryFromRelation :: Relation p r -> SubQuery +-- subQueryFromRelation = configureQuery . subQueryQualifyFromRelation + +-- | Basic monadic join operation using 'MonadQuery'. +queryWithAttr :: MonadQualify ConfigureQuery m + => NodeAttr -> Relation p r -> m (PlaceHolders p, Projection Flat r) +queryWithAttr attr = addPlaceHolders . run where + run rel = do + q <- liftQualify $ do + sq <- subQueryQualifyFromRelation rel + qualifyQuery sq + unsafeSubQuery attr q + -- d (Relation q) = unsafeMergeAnotherQuery attr q + +-- | Join subquery with place-holder parameter 'p'. query result is not 'Maybe'. +query' :: MonadQualify ConfigureQuery m => Relation p r -> m (PlaceHolders p, Projection Flat r) +query' = queryWithAttr Just' + +-- | Join subquery. Query result is not 'Maybe'. +query :: MonadQualify ConfigureQuery m => Relation () r -> m (Projection Flat r) +query = fmap snd . query' + +-- | Join subquery with place-holder parameter 'p'. Query result is 'Maybe'. +queryMaybe' :: MonadQualify ConfigureQuery m => Relation p r -> m (PlaceHolders p, Projection Flat (Maybe r)) +queryMaybe' pr = do + (ph, pj) <- queryWithAttr Maybe pr + return (ph, Projection.just pj) + +-- | Join subquery. Query result is 'Maybe'. +queryMaybe :: MonadQualify ConfigureQuery m => Relation () r -> m (Projection Flat (Maybe r)) +queryMaybe = fmap snd . queryMaybe' + +queryList0 :: MonadQualify ConfigureQuery m => Relation p r -> m (ListProjection (Projection c) r) +queryList0 = liftQualify + . fmap unsafeListProjectionFromSubQuery + . subQueryQualifyFromRelation + +-- | List subQuery, for /IN/ and /EXIST/ with place-holder parameter 'p'. +queryList' :: MonadQualify ConfigureQuery m + => Relation p r + -> m (PlaceHolders p, ListProjection (Projection c) r) +queryList' rel = do + ql <- queryList0 rel + return (placeHoldersFromRelation rel, ql) + +-- | List subQuery, for /IN/ and /EXIST/. +queryList :: MonadQualify ConfigureQuery m + => Relation () r + -> m (ListProjection (Projection c) r) +queryList = queryList0 + +unsafeRelation :: SimpleQuery rp -> Relation p r +unsafeRelation = SubQuery . Simple.toSubQuery + +-- | Finalize 'QuerySimple' monad and generate 'Relation'. +relation :: QuerySimple (Projection Flat r) -> Relation () r +relation = unsafeRelation + +-- | Finalize 'QuerySimple' monad and generate 'Relation' with place-holder parameter 'p'. +relation' :: QuerySimple (PlaceHolders p, Projection Flat r) -> Relation p r +relation' = unsafeRelation . fmap snd + +unsafeAggregateRelation :: AggregatedQuery rp -> Relation p r +unsafeAggregateRelation = SubQuery . Aggregate.toSubQuery + +-- | Finalize 'QueryAggregate' monad and geneate 'Relation'. +aggregateRelation :: QueryAggregate (Projection Aggregated r) -> Relation () r +aggregateRelation = unsafeAggregateRelation + +-- | Finalize 'QueryAggregate' monad and geneate 'Relation' with place-holder parameter 'p'. +aggregateRelation' :: QueryAggregate (PlaceHolders p, Projection Aggregated r) -> Relation p r +aggregateRelation' = unsafeAggregateRelation . fmap snd + + +-- | Restriction function type for direct style join operator. +type JoinRestriction a b = Projection Flat a -> Projection Flat b -> Projection Flat (Maybe Bool) + +unsafeCastPlaceHolder :: Relation a r -> Relation b r +unsafeCastPlaceHolder = d where + d (SubQuery q) = SubQuery q + +-- | Simplify placeholder type applying left identity element. +rightPh :: Relation ((), p) r -> Relation p r +rightPh = unsafeCastPlaceHolder + +-- | Simplify placeholder type applying right identity element. +leftPh :: Relation (p, ()) r -> Relation p r +leftPh = unsafeCastPlaceHolder + +-- | Basic direct join operation with place-holder parameters. +join' :: (qa -> QuerySimple (PlaceHolders pa, Projection Flat a)) + -> (qb -> QuerySimple (PlaceHolders pb, Projection Flat b)) + -> qa + -> qb + -> [JoinRestriction a b] + -> Relation (pa, pb) (a, b) +join' qL qR r0 r1 rs = relation' $ do + (ph0, pj0) <- qL r0 + (ph1, pj1) <- qR r1 + sequence_ [ on $ f pj0 pj1 | f <- rs ] + return (ph0 `projectZip` ph1, pj0 `projectZip` pj1) + +-- | Direct inner join with place-holder parameters. +inner' :: Relation pa a -- ^ Left query to join + -> Relation pb b -- ^ Right query to join + -> [JoinRestriction a b] -- ^ Join restrictions + -> Relation (pa, pb) (a, b) -- ^ Result joined relation +inner' = join' query' query' + +-- | Direct left outer join with place-holder parameters. +left' :: Relation pa a -- ^ Left query to join + -> Relation pb b -- ^ Right query to join + -> [JoinRestriction a (Maybe b)] -- ^ Join restrictions + -> Relation (pa, pb) (a, Maybe b) -- ^ Result joined relation +left' = join' query' queryMaybe' + +-- | Direct right outer join with place-holder parameters. +right' :: Relation pa a -- ^ Left query to join + -> Relation pb b -- ^ Right query to join + -> [JoinRestriction (Maybe a) b] -- ^ Join restrictions + -> Relation (pa, pb)(Maybe a, b) -- ^ Result joined relation +right' = join' queryMaybe' query' + +-- | Direct full outer join with place-holder parameters. +full' :: Relation pa a -- ^ Left query to join + -> Relation pb b -- ^ Right query to join + -> [JoinRestriction (Maybe a) (Maybe b)] -- ^ Join restrictions + -> Relation (pa, pb) (Maybe a, Maybe b) -- ^ Result joined relation +full' = join' queryMaybe' queryMaybe' + +-- | Basic direct join operation. +join :: (qa -> QuerySimple (Projection Flat a)) + -> (qb -> QuerySimple (Projection Flat b)) + -> qa + -> qb + -> [JoinRestriction a b] + -> Relation () (a, b) +join qL qR r0 r1 rs = relation $ do + pj0 <- qL r0 + pj1 <- qR r1 + sequence_ [ on $ f pj0 pj1 | f <- rs ] + return $ pj0 `projectZip` pj1 + +-- | Direct inner join. +inner :: Relation () a -- ^ Left query to join + -> Relation () b -- ^ Right query to join + -> [JoinRestriction a b] -- ^ Join restrictions + -> Relation () (a, b) -- ^ Result joined relation +inner = join query query + +-- | Direct left outer join. +left :: Relation () a -- ^ Left query to join + -> Relation () b -- ^ Right query to join + -> [JoinRestriction a (Maybe b)] -- ^ Join restrictions + -> Relation () (a, Maybe b) -- ^ Result joined relation +left = join query queryMaybe + +-- | Direct right outer join. +right :: Relation () a -- ^ Left query to join + -> Relation () b -- ^ Right query to join + -> [JoinRestriction (Maybe a) b] -- ^ Join restrictions + -> Relation () (Maybe a, b) -- ^ Result joined relation +right = join queryMaybe query + +-- | Direct full outer join. +full :: Relation () a -- ^ Left query to join + -> Relation () b -- ^ Right query to join + -> [JoinRestriction (Maybe a) (Maybe b)] -- ^ Join restrictions + -> Relation () (Maybe a, Maybe b) -- ^ Result joined relation +full = join queryMaybe queryMaybe + +-- | Apply restriction for direct join style. +on' :: ([JoinRestriction a b] -> Relation pc (a, b)) + -> [JoinRestriction a b] + -> Relation pc (a, b) +on' = ($) + +infixl 8 `inner'`, `left'`, `right'`, `full'`, `inner`, `left`, `right`, `full`, `on'` + +unsafeLiftAppend :: (SubQuery -> SubQuery -> SubQuery) + -> Relation p a + -> Relation q a + -> Relation r a +unsafeLiftAppend op a0 a1 = SubQuery $ do + s0 <- subQueryQualifyFromRelation a0 + s1 <- subQueryQualifyFromRelation a1 + return $ s0 `op` s1 + +liftAppend :: (SubQuery -> SubQuery -> SubQuery) + -> Relation () a + -> Relation () a + -> Relation () a +liftAppend = unsafeLiftAppend + +-- | Union of two relations. +union :: Relation () a -> Relation () a -> Relation () a +union = liftAppend $ SubQuery.union Distinct + +-- | Union of two relations. Not distinct. +unionAll :: Relation () a -> Relation () a -> Relation () a +unionAll = liftAppend $ SubQuery.union All + +-- | Subtraction of two relations. +except :: Relation () a -> Relation () a -> Relation () a +except = liftAppend $ SubQuery.except Distinct + +-- | Subtraction of two relations. Not distinct. +exceptAll :: Relation () a -> Relation () a -> Relation () a +exceptAll = liftAppend $ SubQuery.except All + +-- | Intersection of two relations. +intersect :: Relation () a -> Relation () a -> Relation () a +intersect = liftAppend $ SubQuery.intersect Distinct + +-- | Intersection of two relations. Not distinct. +intersectAll :: Relation () a -> Relation () a -> Relation () a +intersectAll = liftAppend $ SubQuery.intersect All + +liftAppend' :: (SubQuery -> SubQuery -> SubQuery) + -> Relation p a + -> Relation q a + -> Relation (p, q) a +liftAppend' = unsafeLiftAppend + +-- | Union of two relations with place-holder parameters. +union' :: Relation p a -> Relation q a -> Relation (p, q) a +union' = liftAppend' $ SubQuery.union Distinct + +-- | Union of two relations with place-holder parameters. Not distinct. +unionAll' :: Relation p a -> Relation q a -> Relation (p, q) a +unionAll' = liftAppend' $ SubQuery.union All + +-- | Subtraction of two relations with place-holder parameters. +except' :: Relation p a -> Relation q a -> Relation (p, q) a +except' = liftAppend' $ SubQuery.except Distinct + +-- | Subtraction of two relations with place-holder parameters. Not distinct. +exceptAll' :: Relation p a -> Relation q a -> Relation (p, q) a +exceptAll' = liftAppend' $ SubQuery.except All + +-- | Intersection of two relations with place-holder parameters. +intersect' :: Relation p a -> Relation q a -> Relation (p, q) a +intersect' = liftAppend' $ SubQuery.intersect Distinct + +-- | Intersection of two relations with place-holder parameters. Not distinct. +intersectAll' :: Relation p a -> Relation q a -> Relation (p, q) a +intersectAll' = liftAppend' $ SubQuery.intersect All + +infixl 7 `union`, `except`, `intersect`, `unionAll`, `exceptAll`, `intersectAll` +infixl 7 `union'`, `except'`, `intersect'`, `unionAll'`, `exceptAll'`, `intersectAll'` + +-- | Generate SQL string from 'Relation' with configuration. +sqlFromRelationWith :: Relation p r -> Config -> StringSQL +sqlFromRelationWith (SubQuery qsub) = configureQuery $ SubQuery.showSQL <$> qsub + +-- | SQL string from 'Relation'. +sqlFromRelation :: Relation p r -> StringSQL +sqlFromRelation = (`sqlFromRelationWith` defaultConfig) + +-- | Dump internal structure tree. +dump :: Relation p r -> String +dump = show . (`configureQuery` defaultConfig) . subQueryQualifyFromRelation + +instance Show (Relation p r) where + show = showStringSQL . sqlFromRelation + +{- +-- | Get projection width from 'Relation'. +width :: Relation p r -> Int +width = SubQuery.width . subQueryFromRelation + +-- | Finalize internal Query monad. +nested :: Relation p r -> Relation p r +nested = SubQuery . subQueryFromRelation +-} + +-- | Unique relation type to compose scalar queries. +newtype UniqueRelation p c r = Unique (Relation p r) + +-- | Unsafely specify unique relation. +unsafeUnique :: Relation p r -> UniqueRelation p c r +unsafeUnique = Unique + +-- | Discard unique attribute. +unUnique :: UniqueRelation p c r -> Relation p r +unUnique (Unique r) = r + +-- | Basic monadic join operation using 'MonadQuery'. +uniqueQueryWithAttr :: MonadQualifyUnique ConfigureQuery m + => NodeAttr + -> UniqueRelation p c r + -> m (PlaceHolders p, Projection c r) +uniqueQueryWithAttr attr = addPlaceHolders . run where + run rel = do + q <- liftQualifyUnique $ do + sq <- subQueryQualifyFromRelation (unUnique rel) + qualifyQuery sq + Projection.unsafeChangeContext <$> unsafeSubQuery attr q + +-- | Join unique subquery with place-holder parameter 'p'. +uniqueQuery' :: MonadQualifyUnique ConfigureQuery m + => UniqueRelation p c r + -> m (PlaceHolders p, Projection c r) +uniqueQuery' = uniqueQueryWithAttr Just' + +-- | Join unique subquery with place-holder parameter 'p'. Query result is 'Maybe'. +uniqueQueryMaybe' :: MonadQualifyUnique ConfigureQuery m + => UniqueRelation p c r + -> m (PlaceHolders p, Projection c (Maybe r)) +uniqueQueryMaybe' pr = do + (ph, pj) <- uniqueQueryWithAttr Maybe pr + return (ph, Projection.just pj) + +-- | Finalize 'QueryUnique' monad and generate 'UniqueRelation'. +uniqueRelation' :: QueryUnique (PlaceHolders p, Projection c r) -> UniqueRelation p c r +uniqueRelation' = unsafeUnique . SubQuery . Unique.toSubQuery . fmap snd + +-- | Aggregated 'UniqueRelation'. +aggregatedUnique :: Relation ph r + -> Pi r a + -> (Projection Flat a -> Projection Aggregated b) + -> UniqueRelation ph Flat b +aggregatedUnique rel k ag = unsafeUnique . aggregateRelation' $ do + (ph, a) <- query' rel + return (ph, ag $ a ! k) + +-- | Scalar subQuery with place-holder parameter 'p'. +queryScalar' :: (MonadQualify ConfigureQuery m, ScalarDegree r) + => UniqueRelation p c r + -> m (PlaceHolders p, Projection c r) +queryScalar' ur = addPlaceHolders . liftQualify $ + Projection.unsafeFromColumns . (:[]) . columnSQL . SubQuery.unitSQL + <$> subQueryQualifyFromRelation (unUnique ur) + +-- | Scalar subQuery. +queryScalar :: (MonadQualify ConfigureQuery m, ScalarDegree r) + => UniqueRelation () c r + -> m (Projection c r) +queryScalar = fmap snd . queryScalar' diff --git a/src/Database/Relational/Query/SQL.hs b/src/Database/Relational/Query/SQL.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Query/SQL.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Database.Relational.Query.SQL +-- Copyright : 2013 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module defines functions to generate simple SQL strings. +module Database.Relational.Query.SQL ( + -- * Query suffix + QuerySuffix, showsQuerySuffix, + + -- * Update SQL + updatePrefixSQL, + updateSQL', + updateOtherThanKeySQL', updateOtherThanKeySQL, + + -- * Insert SQL + insertPrefixSQL, insertSQL, insertSizedChunkSQL, + + -- * Delete SQL + deletePrefixSQL', deletePrefixSQL + ) where + +import Data.Array (listArray, (!)) +import Data.Monoid (mconcat, (<>)) + +import Language.SQL.Keyword (Keyword(..), (.=.), (|*|)) +import qualified Language.SQL.Keyword as SQL + +import Database.Record.ToSql (untypedUpdateValuesIndex) + +import Database.Relational.Query.Internal.SQL (StringSQL, stringSQL, showStringSQL, rowStringSQL) +import Database.Relational.Query.Pi (Pi) +import qualified Database.Relational.Query.Pi.Unsafe as UnsafePi +import Database.Relational.Query.Component (ColumnSQL, showsColumnSQL, showsColumnSQL) +import Database.Relational.Query.Table (Table, name, columns) +import qualified Database.Relational.Query.Projection as Projection + + +-- | Type for query suffix words +type QuerySuffix = [Keyword] + +-- | Expand query suffix words +showsQuerySuffix :: QuerySuffix -> StringSQL +showsQuerySuffix = mconcat + +-- | Generate prefix string of update SQL. +updatePrefixSQL :: Table r -> StringSQL +updatePrefixSQL table = UPDATE <> stringSQL (name table) + +-- | Generate update SQL by specified key and table. +-- Columns name list of table are also required. +updateSQL' :: String -- ^ Table name + -> [ColumnSQL] -- ^ Column name list to update + -> [ColumnSQL] -- ^ Key column name list + -> String -- ^ Result SQL +updateSQL' table cols key = + showStringSQL $ mconcat + [UPDATE, stringSQL table, SET, SQL.fold (|*|) updAssigns, + WHERE, SQL.fold SQL.and keyAssigns] + where + assigns cs = [ showsColumnSQL 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 + -> [ColumnSQL] -- ^ Column name list + -> [Int] -- ^ Key column indexes + -> String -- ^ Result SQL +updateOtherThanKeySQL' table cols ixs = + updateSQL' table updColumns keyColumns + where + width' = length cols + cols' = listArray (0, width' -1) cols + otherThanKey = untypedUpdateValuesIndex ixs width' + columns' is = [ cols' ! i | i <- is ] + updColumns = columns' otherThanKey + keyColumns = columns' ixs + +-- | Generate update SQL specified by single key. +updateOtherThanKeySQL :: Table r -- ^ Table metadata + -> Pi r p -- ^ Key columns + -> String -- ^ Result SQL +updateOtherThanKeySQL tbl key = + updateOtherThanKeySQL' (name tbl) (columns tbl) (UnsafePi.unsafeExpandIndexes key) + +-- | Generate prefix string of insert SQL. +insertPrefixSQL :: Pi r r' -> Table r -> StringSQL +insertPrefixSQL pi' table = + INSERT <> INTO <> stringSQL (name table) <> rowStringSQL [showsColumnSQL c | c <- cols] where + cols = Projection.columns . Projection.pi (Projection.unsafeFromTable table) $ pi' + +-- | Generate records chunk insert SQL. +insertChunkSQL :: Int -- ^ Records count to insert + -> Pi r r' -- ^ Columns selector to insert + -> Table r -- ^ Table metadata + -> String -- ^ Result SQL +insertChunkSQL n0 pi' tbl = showStringSQL $ insertPrefixSQL pi' tbl <> VALUES <> vs where + n | n0 >= 1 = n0 + | otherwise = error $ "Invalid chunk count value: " ++ show n0 + w = UnsafePi.width pi' + vs = SQL.fold (|*|) . replicate n $ rowStringSQL (replicate w "?") + +-- | Generate size measured records chunk insert SQL. +insertSizedChunkSQL :: Pi r r' -- ^ Columns selector to insert + -> Table r -- ^ Table metadata + -> Int -- ^ Chunk size threshold (column count) + -> (String, Int) -- ^ Result SQL and records count of chunk +insertSizedChunkSQL pi' tbl th = (insertChunkSQL n pi' tbl, n) where + w = UnsafePi.width pi' + n = th `quot` w + 1 + +-- | Generate insert SQL. +insertSQL :: Pi r r' -- ^ Columns selector to insert + -> Table r -- ^ Table metadata + -> String -- ^ Result SQL +insertSQL = insertChunkSQL 1 + +-- | Generate all column delete SQL by specified table. Untyped table version. +deletePrefixSQL' :: String -> StringSQL +deletePrefixSQL' table = DELETE <> FROM <> stringSQL table + +-- | Generate all column delete SQL by specified table. +deletePrefixSQL :: Table r -- ^ Table metadata + -> StringSQL -- ^ Result SQL +deletePrefixSQL = deletePrefixSQL' . name diff --git a/src/Database/Relational/Query/Scalar.hs b/src/Database/Relational/Query/Scalar.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Query/Scalar.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleInstances #-} + +-- | +-- Module : Database.Relational.Query.Scalar +-- Copyright : 2013 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module defines type classes and templates for scalar queries. +module Database.Relational.Query.Scalar ( + -- * Single degree constraint + ScalarDegree, defineScalarDegree + ) where + +import Language.Haskell.TH (Q, TypeQ, Dec) +import Database.Record (PersistableWidth) + + +-- | Constraint which represents scalar degree. +class PersistableWidth ct => ScalarDegree ct + +instance ScalarDegree ct => ScalarDegree (Maybe ct) + +-- | 'ScalarDegree' instance templates. +defineScalarDegree :: TypeQ -> Q [Dec] +defineScalarDegree typeCon = do + [d| instance ScalarDegree $(typeCon) |] diff --git a/src/Database/Relational/Query/Sub.hs b/src/Database/Relational/Query/Sub.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Query/Sub.hs @@ -0,0 +1,351 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Database.Relational.Query.Sub +-- Copyright : 2013 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module defines sub-query structure used in query products. +module Database.Relational.Query.Sub ( + -- * Sub-query + SubQuery, fromTable, flatSubQuery, aggregatedSubQuery, + union, except, intersect, + showSQL, toSQL, unitSQL, width, + + -- * Qualified Sub-query + Qualifier (Qualifier), + Qualified, qualifier, unQualify, qualify, + queryWidth, + + -- * Sub-query columns + column, + + -- * Untyped projection + ProjectionUnit, UntypedProjection, + + untypedProjectionFromColumns, untypedProjectionFromSubQuery, + widthOfUntypedProjection, columnsOfUntypedProjection, + + + -- * Product of sub-queries + QueryProduct, QueryProductNode, JoinProduct, + ) where + +import Data.Maybe (fromMaybe) +import Data.Array (Array, listArray) +import qualified Data.Array as Array +import Data.Monoid (mempty, (<>), mconcat) + +import qualified Database.Relational.Query.Context as Context +import Database.Relational.Query.Expr (valueExpr) +import Database.Relational.Query.Expr.Unsafe (sqlExpr) +import Database.Relational.Query.Internal.SQL (StringSQL, stringSQL, showStringSQL) +import Database.Relational.Query.Internal.Product + (NodeAttr(Just', Maybe), ProductTree (Leaf, Join), + Node, nodeAttr, nodeTree) +import Database.Relational.Query.Component + (ColumnSQL, columnSQL', showsColumnSQL, + Config (productUnitSupport), ProductUnitSupport (PUSupported, PUNotSupported), + Duplication, showsDuplication, QueryRestriction, composeWhere, composeHaving, + AggregateElem, composeGroupBy, OrderingTerms, composeOrderBy) +import Database.Relational.Query.Table (Table, (!)) +import qualified Database.Relational.Query.Table as Table + +import Language.SQL.Keyword (Keyword(..), (|*|)) +import qualified Language.SQL.Keyword as SQL + + +data SetOp = Union | Except | Intersect deriving Show + +newtype BinOp = BinOp (SetOp, Duplication) deriving Show + +showsSetOp :: SetOp -> StringSQL +showsSetOp = d where + d Union = UNION + d Except = EXCEPT + d Intersect = INTERSECT + +-- | Sub-query type +data SubQuery = Table Table.Untyped + | Flat Config + UntypedProjection Duplication JoinProduct (QueryRestriction Context.Flat) + OrderingTerms + | Aggregated Config + UntypedProjection Duplication JoinProduct (QueryRestriction Context.Flat) + [AggregateElem] (QueryRestriction Context.Aggregated) OrderingTerms + | Bin BinOp SubQuery SubQuery + deriving Show + +-- | 'SubQuery' from 'Table'. +fromTable :: Table r -- ^ Typed 'Table' metadata + -> SubQuery -- ^ Result 'SubQuery' +fromTable = Table . Table.unType + +-- | Unsafely generate flat 'SubQuery' from untyped components. +flatSubQuery :: Config + -> UntypedProjection + -> Duplication + -> JoinProduct + -> QueryRestriction Context.Flat + -> OrderingTerms + -> SubQuery +flatSubQuery = Flat + +-- | Unsafely generate aggregated 'SubQuery' from untyped components. +aggregatedSubQuery :: Config + -> UntypedProjection + -> Duplication + -> JoinProduct + -> QueryRestriction Context.Flat + -> [AggregateElem] + -> QueryRestriction Context.Aggregated + -> OrderingTerms + -> SubQuery +aggregatedSubQuery = Aggregated + +setBin :: SetOp -> Duplication -> SubQuery -> SubQuery -> SubQuery +setBin op = Bin . BinOp . (,) op + +-- | Union binary operator on 'SubQuery' +union :: Duplication -> SubQuery -> SubQuery -> SubQuery +union = setBin Union + +-- | Except binary operator on 'SubQuery' +except :: Duplication -> SubQuery -> SubQuery -> SubQuery +except = setBin Except + +-- | Intersect binary operator on 'SubQuery' +intersect :: Duplication -> SubQuery -> SubQuery -> SubQuery +intersect = setBin Intersect + +-- | Width of 'SubQuery'. +width :: SubQuery -> Int +width = d where + d (Table u) = Table.width' u + d (Bin _ l _) = width l + d (Flat _ up _ _ _ _) = widthOfUntypedProjection up + d (Aggregated _ up _ _ _ _ _ _) = widthOfUntypedProjection up + +-- | SQL to query table. +fromTableToSQL :: Table.Untyped -> StringSQL +fromTableToSQL t = + SELECT <> SQL.fold (|*|) [showsColumnSQL c | c <- Table.columns' t] <> + FROM <> stringSQL (Table.name' t) + +-- | Generate normalized column SQL from table. +fromTableToNormalizedSQL :: Table.Untyped -> StringSQL +fromTableToNormalizedSQL t = SELECT <> SQL.fold (|*|) columns' <> + FROM <> stringSQL (Table.name' t) where + columns' = zipWith asColumnN + (Table.columns' t) + [(0 :: Int)..] + +-- | Normalized column SQL +normalizedSQL :: SubQuery -> StringSQL +normalizedSQL = d where + d (Table t) = fromTableToNormalizedSQL t + d sub@(Bin {}) = showUnitSQL sub + d sub@(Flat {}) = showUnitSQL sub + d sub@(Aggregated {}) = showUnitSQL sub + +selectPrefixSQL :: UntypedProjection -> Duplication -> StringSQL +selectPrefixSQL up da = SELECT <> showsDuplication da <> + SQL.fold (|*|) columns' where + columns' = zipWith asColumnN + (columnsOfUntypedProjection up) + [(0 :: Int)..] + +-- | SQL string for nested-query and toplevel-SQL. +toSQLs :: SubQuery + -> (StringSQL, StringSQL) -- ^ subquery SQL and top-level SQL +toSQLs = d where + d (Table u) = (stringSQL $ Table.name' u, fromTableToSQL u) + d (Bin (BinOp (op, da)) l r) = (SQL.paren q, q) where + q = mconcat [normalizedSQL l, showsSetOp op, showsDuplication da, normalizedSQL r] + d (Flat cf up da pd rs od) = (SQL.paren q, q) where + q = selectPrefixSQL up da <> showsJoinProduct (productUnitSupport cf) pd <> composeWhere rs + <> composeOrderBy od + d (Aggregated cf up da pd rs ag grs od) = (SQL.paren q, q) where + q = selectPrefixSQL up da <> showsJoinProduct (productUnitSupport cf) pd <> composeWhere rs + <> composeGroupBy ag <> composeHaving grs <> composeOrderBy od + +showUnitSQL :: SubQuery -> StringSQL +showUnitSQL = fst . toSQLs + +-- | SQL string for nested-qeury. +unitSQL :: SubQuery -> String +unitSQL = showStringSQL . showUnitSQL + +-- | SQL StringSQL for toplevel-SQL. +showSQL :: SubQuery -> StringSQL +showSQL = snd . toSQLs + +-- | SQL string for toplevel-SQL. +toSQL :: SubQuery -> String +toSQL = showStringSQL . showSQL + +-- | Qualifier type. +newtype Qualifier = Qualifier Int deriving Show + +-- | Qualified query. +data Qualified a = Qualified a Qualifier deriving Show + +-- | 'Functor' instance of 'Qualified' +instance Functor Qualified where + fmap f (Qualified a i) = Qualified (f a) i + +-- | Get qualifier +qualifier :: Qualified a -> Qualifier +qualifier (Qualified _ i) = i + +-- | Unqualify. +unQualify :: Qualified a -> a +unQualify (Qualified a _) = a + +-- | Add qualifier +qualify :: a -> Qualifier -> Qualified a +qualify = Qualified + +columnN :: Int -> StringSQL +columnN i = stringSQL $ 'f' : show i + +asColumnN :: ColumnSQL -> Int -> StringSQL +c `asColumnN` n = showsColumnSQL c `SQL.as` columnN n + +-- | Alias string from qualifier +showQualifier :: Qualifier -> StringSQL +showQualifier (Qualifier i) = stringSQL $ 'T' : show i + +-- | Binary operator to qualify. +(<.>) :: Qualifier -> ColumnSQL -> ColumnSQL +i <.> n = fmap (showQualifier i SQL.<.>) n + +-- | Qualified expression from qualifier and projection index. +columnFromId :: Qualifier -> Int -> ColumnSQL +columnFromId qi i = qi <.> columnSQL' (columnN i) + +-- | From 'Qualified' SQL string into 'String'. +qualifiedSQLas :: Qualified StringSQL -> StringSQL +qualifiedSQLas q = unQualify q <> showQualifier (qualifier q) + +-- | Width of 'Qualified' 'SubQUery'. +queryWidth :: Qualified SubQuery -> Int +queryWidth = width . unQualify + +-- | Get column SQL string of 'SubQuery'. +column :: Qualified SubQuery -> Int -> ColumnSQL +column qs = d (unQualify qs) where + q = qualifier qs + d (Table u) i = q <.> (u ! i) + d (Bin {}) i = q `columnFromId` i + d (Flat _ up _ _ _ _) i = columnOfUntypedProjection up i + d (Aggregated _ up _ _ _ _ _ _) i = columnOfUntypedProjection up i + +-- | Get qualified SQL string, like (SELECT ...) AS T0 +qualifiedForm :: Qualified SubQuery -> StringSQL +qualifiedForm = qualifiedSQLas . fmap showUnitSQL + + +-- | Projection structure unit +data ProjectionUnit = Columns (Array Int ColumnSQL) + | Normalized (Qualified Int) + deriving Show + +projectionUnitFromColumns :: [ColumnSQL] -> ProjectionUnit +projectionUnitFromColumns cs = Columns $ listArray (0, length cs - 1) cs + +-- | Untyped projection. Forgot record type. +type UntypedProjection = [ProjectionUnit] + +unitUntypedProjection :: ProjectionUnit -> UntypedProjection +unitUntypedProjection = (:[]) + +-- | Make untyped projection from columns. +untypedProjectionFromColumns :: [ColumnSQL] -> UntypedProjection +untypedProjectionFromColumns = unitUntypedProjection . projectionUnitFromColumns + +-- | Make untyped projection from sub query. +untypedProjectionFromSubQuery :: Qualified SubQuery -> UntypedProjection +untypedProjectionFromSubQuery qs = d $ unQualify qs where -- unitUntypedProjection . Sub + normalized = unitUntypedProjection . Normalized $ fmap width qs + d (Table _) = untypedProjectionFromColumns . map (column qs) + $ take (queryWidth qs) [0..] + d (Bin {}) = normalized + d (Flat {}) = normalized + d (Aggregated {}) = normalized + +-- | ProjectionUnit width. +widthOfProjectionUnit :: ProjectionUnit -> Int +widthOfProjectionUnit = d where + d (Columns a) = mx - mn + 1 where (mn, mx) = Array.bounds a + d (Normalized qw) = unQualify qw + +-- | Get column of ProjectionUnit. +columnOfProjectionUnit :: ProjectionUnit -> Int -> ColumnSQL +columnOfProjectionUnit = d where + d (Columns a) i | mn <= i && i <= mx = a Array.! i + | otherwise = error $ "index out of bounds (unit): " ++ show i + where (mn, mx) = Array.bounds a + d (Normalized qw) i | i < w = qualifier qw `columnFromId` i + | otherwise = error $ "index out of bounds (normalized unit): " ++ show i + where w = unQualify qw + +-- | Width of 'UntypedProjection'. +widthOfUntypedProjection :: UntypedProjection -> Int +widthOfUntypedProjection = sum . map widthOfProjectionUnit + +-- | Get column SQL string of 'UntypedProjection'. +columnOfUntypedProjection :: UntypedProjection -- ^ Source 'Projection' + -> Int -- ^ Column index + -> ColumnSQL -- ^ Result SQL string +columnOfUntypedProjection up i' = rec up i' where + rec [] _ = error $ "index out of bounds: " ++ show i' + rec (u : us) i + | i < widthOfProjectionUnit u = columnOfProjectionUnit u i + | i < 0 = error $ "index out of bounds: " ++ show i + | otherwise = rec us (i - widthOfProjectionUnit u) + +-- | Get column SQL string list of projection. +columnsOfUntypedProjection :: UntypedProjection -- ^ Source 'Projection' + -> [ColumnSQL] -- ^ Result SQL string list +columnsOfUntypedProjection p = map (columnOfUntypedProjection p) . take w $ [0 .. ] + where w = widthOfUntypedProjection p + + +-- | Product tree specialized by 'SubQuery'. +type QueryProduct = ProductTree (Qualified SubQuery) +-- | Product node specialized by 'SubQuery'. +type QueryProductNode = Node (Qualified SubQuery) + +-- | Show product tree of query into SQL. StringSQL result. +showsQueryProduct :: QueryProduct -> StringSQL +showsQueryProduct = rec where + joinType Just' Just' = INNER + joinType Just' Maybe = LEFT + joinType Maybe Just' = RIGHT + joinType Maybe Maybe = FULL + urec n = case nodeTree n of + p@(Leaf _) -> rec p + p@(Join {}) -> SQL.paren (rec p) + rec (Leaf q) = qualifiedForm q + rec (Join left' right' rs) = + mconcat + [urec left', + joinType (nodeAttr left') (nodeAttr right'), JOIN, + urec right', + ON, + sqlExpr . fromMaybe (valueExpr True) {- or error on compile -} $ rs] + +-- | Type for join product of query. +type JoinProduct = Maybe QueryProduct + +-- | Shows join product of query. +showsJoinProduct :: ProductUnitSupport -> JoinProduct -> StringSQL +showsJoinProduct ups = maybe (up ups) from where + from qp = FROM <> showsQueryProduct qp + up PUSupported = mempty + up PUNotSupported = error "relation: Unit product support mode is disabled!" diff --git a/src/Database/Relational/Query/TH.hs b/src/Database/Relational/Query/TH.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Query/TH.hs @@ -0,0 +1,451 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE ParallelListComp #-} + +-- | +-- Module : Database.Relational.Query.TH +-- Copyright : 2013 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module defines templates for Haskell record type and type class instances +-- to define column projection on SQL query like Haskell records. +-- Templates are generated by also using functions of "Database.Record.TH" module, +-- so mapping between list of untyped SQL type and Haskell record type will be done too. +module Database.Relational.Query.TH ( + -- * All templates about table + defineTableDefault, + + -- * Inlining typed 'Query' + unsafeInlineQuery, + inlineQuery, + + -- * Column projections and basic 'Relation' for Haskell record + defineTableTypesAndRecordDefault, + + -- * Constraint key templates + defineHasPrimaryKeyInstance, + defineHasPrimaryKeyInstanceDefault, + defineHasNotNullKeyInstance, + defineHasNotNullKeyInstanceDefault, + defineScalarDegree, + + -- * Column projections + defineColumns, defineColumnsDefault, + + -- * Table metadata type and basic 'Relation' + defineTableTypes, defineTableTypesDefault, + + -- * Basic SQL templates generate rules + definePrimaryQuery, + definePrimaryUpdate, + + -- * Var expression templates + derivationExpDefault, + tableVarExpDefault, + relationVarExpDefault, + + -- * Derived SQL templates from table definitions + defineSqlsWithPrimaryKey, + defineSqlsWithPrimaryKeyDefault, + + -- * Add type class instance against record type + defineProductConstructorInstance, + + -- * Reify + makeRelationalRecordDefault, + reifyRelation, + ) where + +import Data.Char (toUpper, toLower) +import Data.List (foldl1') +import Data.Array.IArray ((!)) + +import Language.Haskell.TH + (Name, nameBase, Q, reify, Info (VarI), TypeQ, Type (AppT, ConT), ExpQ, + tupleT, appT, arrowT, Dec, stringE, listE) +import Language.Haskell.TH.Name.CamelCase + (VarName, varName, ConName (ConName), conName, varNameWithPrefix, varCamelcaseName, toVarExp, toTypeCon, toDataCon) +import Language.Haskell.TH.Lib.Extra (simpleValD, maybeD, integralE) + +import Database.Record.TH + (recordTypeNameDefault, recordTypeDefault, columnOffsetsVarNameDefault, + defineRecordTypeDefault, + defineHasColumnConstraintInstance) +import qualified Database.Record.TH as Record +import Database.Record.Instances () + +import Database.Relational.Query + (Table, Pi, Relation, Config (normalizedTableName), ProductConstructor (..), + relationalQuerySQL, Query, relationalQuery, KeyUpdate, + Insert, derivedInsert, InsertQuery, derivedInsertQuery, + HasConstraintKey(constraintKey), Primary, NotNull, primary, primaryUpdate) + +import Database.Relational.Query.Scalar (defineScalarDegree) +import Database.Relational.Query.Constraint (Key, unsafeDefineConstraintKey) +import Database.Relational.Query.Table (TableDerivable (..)) +import qualified Database.Relational.Query.Table as Table +import Database.Relational.Query.Relation (derivedRelation) +import Database.Relational.Query.SQL (QuerySuffix) +import Database.Relational.Query.Type (unsafeTypedQuery) +import qualified Database.Relational.Query.Pi.Unsafe as UnsafePi + + +-- | Rule template to infer constraint key. +defineHasConstraintKeyInstance :: TypeQ -- ^ Constraint type + -> TypeQ -- ^ Record type + -> TypeQ -- ^ Key type + -> [Int] -- ^ Indexes specifies key + -> Q [Dec] -- ^ Result 'HasConstraintKey' declaration +defineHasConstraintKeyInstance constraint recType colType indexes = do + -- kc <- defineHasColumnConstraintInstance constraint recType index + ck <- [d| instance HasConstraintKey $constraint $recType $colType where + constraintKey = unsafeDefineConstraintKey $(listE [integralE ix | ix <- indexes]) + |] + return ck + +-- | Rule template to infer primary key. +defineHasPrimaryKeyInstance :: TypeQ -- ^ Record type + -> TypeQ -- ^ Key type + -> [Int] -- ^ Indexes specifies key + -> Q [Dec] -- ^ Result constraint key declarations +defineHasPrimaryKeyInstance recType colType indexes = do + kc <- Record.defineHasPrimaryKeyInstance recType indexes + ck <- defineHasConstraintKeyInstance [t| Primary |] recType colType indexes + return $ kc ++ ck + +-- | Rule template to infer primary key. +defineHasPrimaryKeyInstanceDefault :: String -- ^ Table name + -> TypeQ -- ^ Column type + -> [Int] -- ^ Primary key index + -> Q [Dec] -- ^ Declarations of primary constraint key +defineHasPrimaryKeyInstanceDefault = + defineHasPrimaryKeyInstance . recordTypeDefault + +-- | Rule template to infer not-null key. +defineHasNotNullKeyInstance :: TypeQ -- ^ Record type + -> Int -- ^ Column index + -> Q [Dec] -- ^ Result 'ColumnConstraint' declaration +defineHasNotNullKeyInstance = + defineHasColumnConstraintInstance [t| NotNull |] + +-- | Rule template to infer not-null key. +defineHasNotNullKeyInstanceDefault :: String -- ^ Table name + -> Int -- ^ NotNull key index + -> Q [Dec] -- ^ Declaration of not-null constraint key +defineHasNotNullKeyInstanceDefault = + defineHasNotNullKeyInstance . recordTypeDefault + + +-- | Column projection path 'Pi' template. +columnTemplate' :: TypeQ -- ^ Record type + -> VarName -- ^ Column declaration variable name + -> ExpQ -- ^ Column index expression in record (begin with 0) + -> TypeQ -- ^ Column type + -> Q [Dec] -- ^ Column projection path declaration +columnTemplate' recType var' iExp colType = do + let var = varName var' + simpleValD var [t| Pi $recType $colType |] + [| UnsafePi.definePi $(iExp) |] + +-- | Column projection path 'Pi' and constraint key template. +columnTemplate :: Maybe (TypeQ, VarName) -- ^ May Constraint type and constraint object name + -> TypeQ -- ^ Record type + -> VarName -- ^ Column declaration variable name + -> ExpQ -- ^ Column index expression in record (begin with 0) + -> TypeQ -- ^ Column type + -> Q [Dec] -- ^ Column projection path declaration +columnTemplate mayConstraint recType var' iExp colType = do + col <- columnTemplate' recType var' iExp colType + cr <- maybe + (return []) + ( \(constraint, cname') -> do + simpleValD (varName cname') [t| Key $constraint $recType $colType |] + [| unsafeDefineConstraintKey $(iExp) |] ) + mayConstraint + return $ col ++ cr + +-- | Column projection path 'Pi' templates. +defineColumns :: ConName -- ^ Record type name + -> [((VarName, TypeQ), Maybe (TypeQ, VarName))] -- ^ Column info list + -> Q [Dec] -- ^ Column projection path declarations +defineColumns recTypeName cols = do + let defC ((cn, ct), mayCon) ix = columnTemplate mayCon (toTypeCon recTypeName) cn + [| $(toVarExp . columnOffsetsVarNameDefault $ conName recTypeName) ! $(integralE ix) |] ct + fmap concat . sequence $ zipWith defC cols [0 :: Int ..] + +-- | Make column projection path and constraint key templates using default naming rule. +defineColumnsDefault :: ConName -- ^ Record type name + -> [((String, TypeQ), Maybe TypeQ)] -- ^ Column info list + -> Q [Dec] -- ^ Column projection path declarations +defineColumnsDefault recTypeName cols = + defineColumns recTypeName [((varN n, ct), fmap (withCName n) mayC) | ((n, ct), mayC) <- cols] + where varN name = varCamelcaseName (name ++ "'") + withCName name t = (t, varCamelcaseName ("constraint_key_" ++ name)) + +-- | Rule template to infer table derivations. +defineTableDerivableInstance :: TypeQ -> String -> [String] -> Q [Dec] +defineTableDerivableInstance recordType table columns = + [d| instance TableDerivable $recordType where + derivedTable = Table.table $(stringE table) $(listE $ map stringE columns) + |] + +-- | Template to define infered entries from table type. +defineTableDerivations :: VarName -- ^ Table declaration variable name + -> VarName -- ^ Relation declaration variable name + -> VarName -- ^ Insert statement declaration variable name + -> VarName -- ^ InsertQuery statement declaration variable name + -> TypeQ -- ^ Record type + -> Q [Dec] -- ^ Table and Relation declaration +defineTableDerivations tableVar' relVar' insVar' insQVar' recordType = do + let tableVar = varName tableVar' + tableDs <- simpleValD tableVar [t| Table $recordType |] + [| derivedTable |] + let relVar = varName relVar' + relDs <- simpleValD relVar [t| Relation () $recordType |] + [| derivedRelation |] + let insVar = varName insVar' + insDs <- simpleValD insVar [t| Insert $recordType |] + [| derivedInsert |] + let insQVar = varName insQVar' + insQDs <- simpleValD insQVar [t| forall p . Relation p $recordType -> InsertQuery p |] + [| derivedInsertQuery |] + return $ concat [tableDs, relDs, insDs, insQDs] + +-- | 'Table' and 'Relation' templates. +defineTableTypes :: VarName -- ^ Table declaration variable name + -> VarName -- ^ Relation declaration variable name + -> VarName -- ^ Insert statement declaration variable name + -> VarName -- ^ InsertQuery statement declaration variable name + -> TypeQ -- ^ Record type + -> String -- ^ Table name in SQL ex. FOO_SCHEMA.table0 + -> [String] -- ^ Column names + -> Q [Dec] -- ^ Table and Relation declaration +defineTableTypes tableVar' relVar' insVar' insQVar' recordType table columns = do + iDs <- defineTableDerivableInstance recordType table columns + dDs <- defineTableDerivations tableVar' relVar' insVar' insQVar' recordType + return $ iDs ++ dDs + +tableSQL :: Bool -> String -> String -> String +tableSQL normalize schema table = normalizeS schema ++ '.' : normalizeT table where + normalizeS + | normalize = map toUpper + | otherwise = id + normalizeT + | normalize = map toLower + | otherwise = id + +derivationVarNameDefault :: String -> VarName +derivationVarNameDefault = (`varNameWithPrefix` "derivationFrom") + +-- | Make 'TableDerivation' variable expression template from table name using default naming rule. +derivationExpDefault :: String -- ^ Table name string + -> ExpQ -- ^ Result var Exp +derivationExpDefault = toVarExp . derivationVarNameDefault + +tableVarNameDefault :: String -> VarName +tableVarNameDefault = (`varNameWithPrefix` "tableOf") + +-- | Make 'Table' variable expression template from table name using default naming rule. +tableVarExpDefault :: String -- ^ Table name string + -> ExpQ -- ^ Result var Exp +tableVarExpDefault = toVarExp . tableVarNameDefault + +relationVarNameDefault :: String -> VarName +relationVarNameDefault = varCamelcaseName + +-- | Make 'Relation' variable expression template from table name using default naming rule. +relationVarExpDefault :: String -- ^ Table name string + -> ExpQ -- ^ Result var Exp +relationVarExpDefault = toVarExp . relationVarNameDefault + +-- | Make template for 'ProductConstructor' instance. +defineProductConstructorInstance :: TypeQ -> ExpQ -> [TypeQ] -> Q [Dec] +defineProductConstructorInstance recTypeQ recData colTypes = + [d| instance ProductConstructor $(foldr (appT . (arrowT `appT`)) recTypeQ colTypes) where + productConstructor = $(recData) + |] + +-- | Make template for record 'ProductConstructor' instance using default naming rule. +defineProductConstructorInstanceDefault :: String -> [TypeQ] -> Q [Dec] +defineProductConstructorInstanceDefault table colTypes = do + let typeName = recordTypeNameDefault table + defineProductConstructorInstance + (toTypeCon typeName) + (toDataCon typeName) + colTypes + +-- | Make templates about table and column metadatas using default naming rule. +defineTableTypesDefault :: Config -- ^ Configuration to generate query with + -> String -- ^ Schema name + -> String -- ^ Table name + -> [((String, TypeQ), Maybe TypeQ)] -- ^ Column names and types and constraint type + -> Q [Dec] -- ^ Result declarations +defineTableTypesDefault config schema table columns = do + tableDs <- defineTableTypes + (tableVarNameDefault table) + (relationVarNameDefault table) + (table `varNameWithPrefix` "insert") + (table `varNameWithPrefix` "insertQuery") + (recordTypeDefault table) + (tableSQL (normalizedTableName config) schema table) + (map (fst . fst) columns) + colsDs <- defineColumnsDefault (recordTypeNameDefault table) columns + return $ tableDs ++ colsDs + +-- | Make templates about table, column and haskell record using default naming rule. +defineTableTypesAndRecordDefault :: Config -- ^ Configuration to generate query with + -> String -- ^ Schema name + -> String -- ^ Table name + -> [(String, TypeQ)] -- ^ Column names and types + -> [ConName] -- ^ Record derivings + -> Q [Dec] -- ^ Result declarations +defineTableTypesAndRecordDefault config schema table columns drives = do + recD <- defineRecordTypeDefault table columns drives + rconD <- defineProductConstructorInstanceDefault table [t | (_, t) <- columns] + tableDs <- defineTableTypesDefault config schema table [(c, Nothing) | c <- columns ] + return $ recD ++ rconD ++ tableDs + +-- | Template of derived primary 'Query'. +definePrimaryQuery :: VarName -- ^ Variable name of result declaration + -> TypeQ -- ^ Parameter type of 'Query' + -> TypeQ -- ^ Record type of 'Query' + -> ExpQ -- ^ 'Relation' expression + -> Q [Dec] -- ^ Result 'Query' declaration +definePrimaryQuery toDef' paramType recType relE = do + let toDef = varName toDef' + simpleValD toDef + [t| Query $paramType $recType |] + [| relationalQuery (primary $relE) |] + +-- | Template of derived primary 'Update'. +definePrimaryUpdate :: VarName -- ^ Variable name of result declaration + -> TypeQ -- ^ Parameter type of 'Update' + -> TypeQ -- ^ Record type of 'Update' + -> ExpQ -- ^ 'Table' expression + -> Q [Dec] -- ^ Result 'Update' declaration +definePrimaryUpdate toDef' paramType recType tableE = do + let toDef = varName toDef' + simpleValD toDef + [t| KeyUpdate $paramType $recType |] + [| primaryUpdate $tableE |] + + +-- | SQL templates derived from primary key. +defineSqlsWithPrimaryKey :: VarName -- ^ Variable name of select query definition from primary key + -> VarName -- ^ Variable name of update statement definition from primary key + -> TypeQ -- ^ Primary key type + -> TypeQ -- ^ Record type + -> ExpQ -- ^ Relation expression + -> ExpQ -- ^ Table expression + -> Q [Dec] -- ^ Result declarations +defineSqlsWithPrimaryKey sel upd paramType recType relE tableE = do + selD <- definePrimaryQuery sel paramType recType relE + updD <- definePrimaryUpdate upd paramType recType tableE + return $ selD ++ updD + +-- | SQL templates derived from primary key using default naming rule. +defineSqlsWithPrimaryKeyDefault :: String -- ^ Table name of Database + -> TypeQ -- ^ Primary key type + -> TypeQ -- ^ Record type + -> ExpQ -- ^ Relation expression + -> ExpQ -- ^ Table expression + -> Q [Dec] -- ^ Result declarations +defineSqlsWithPrimaryKeyDefault table = + defineSqlsWithPrimaryKey sel upd + where + sel = table `varNameWithPrefix` "select" + upd = table `varNameWithPrefix` "update" + +-- | All templates about primary key. +defineWithPrimaryKeyDefault :: String -- ^ Table name string + -> TypeQ -- ^ Type of primary key + -> [Int] -- ^ Indexes specifies primary key + -> Q [Dec] -- ^ Result declarations +defineWithPrimaryKeyDefault table keyType ixs = do + instD <- defineHasPrimaryKeyInstanceDefault table keyType ixs + let recType = recordTypeDefault table + tableE = tableVarExpDefault table + relE = relationVarExpDefault table + sqlsD <- defineSqlsWithPrimaryKeyDefault table keyType recType relE tableE + return $ instD ++ sqlsD + +-- | All templates about not-null key. +defineWithNotNullKeyDefault :: String -> Int -> Q [Dec] +defineWithNotNullKeyDefault = defineHasNotNullKeyInstanceDefault + +-- | Generate all templtes about table using default naming rule. +defineTableDefault :: Config -- ^ Configuration to generate query with + -> String -- ^ Schema name string of Database + -> String -- ^ Table name string of Database + -> [(String, TypeQ)] -- ^ Column names and types + -> [ConName] -- ^ derivings for Record type + -> [Int] -- ^ Primary key index + -> Maybe Int -- ^ Not null key index + -> Q [Dec] -- ^ Result declarations +defineTableDefault config schema table columns derives primaryIxs mayNotNullIdx = do + tblD <- defineTableTypesAndRecordDefault config schema table columns derives + let pairT x y = appT (appT (tupleT 2) x) y + keyType = foldl1' pairT . map (snd . (columns !!)) $ primaryIxs + primD <- case primaryIxs of + [] -> return [] + ixs -> defineWithPrimaryKeyDefault table keyType ixs + nnD <- maybeD (\i -> defineWithNotNullKeyDefault table i) mayNotNullIdx + return $ tblD ++ primD ++ nnD + + +-- | Unsafely inlining SQL string 'Query' in compile type. +unsafeInlineQuery :: TypeQ -- ^ Query parameter type + -> TypeQ -- ^ Query result type + -> String -- ^ SQL string query to inline + -> VarName -- ^ Variable name for inlined query + -> Q [Dec] -- ^ Result declarations +unsafeInlineQuery p r sql qVar' = + simpleValD (varName qVar') + [t| Query $p $r |] + [| unsafeTypedQuery $(stringE sql) |] + +-- | Extract param type and result type from defined Relation +reifyRelation :: Name -- ^ Variable name which has Relation type + -> Q (Type, Type) -- ^ Extracted param type and result type from Relation type +reifyRelation relVar = do + relInfo <- reify relVar + case relInfo of + VarI _ (AppT (AppT (ConT prn) p) r) _ _ + | prn == ''Relation -> return (p, r) + _ -> + fail $ "expandRelation: Variable must have Relation type: " ++ show relVar + +-- | Inlining composed 'Query' in compile type. +inlineQuery :: Name -- ^ Top-level variable name which has 'Relation' type + -> Relation p r -- ^ Object which has 'Relation' type + -> Config -- ^ Configuration to generate SQL + -> QuerySuffix -- ^ suffix SQL words + -> String -- ^ Variable name to define as inlined query + -> Q [Dec] -- ^ Result declarations +inlineQuery relVar rel config sufs qns = do + (p, r) <- reifyRelation relVar + unsafeInlineQuery (return p) (return r) + (relationalQuerySQL config rel sufs) + (varCamelcaseName qns) + +-- | Generate all templates against defined record like type constructor +-- other than depending on sql-value type. +makeRelationalRecordDefault :: Name -- ^ Type constructor name + -> Q [Dec] -- ^ Resutl declaration +makeRelationalRecordDefault recTypeName = do + let recTypeConName = ConName recTypeName + ((tyCon, dataCon), (mayNs, cts)) <- Record.reifyRecordType recTypeName + pw <- Record.defineColumnOffsets recTypeConName cts + cs <- maybe + (return []) + (\ns -> defineColumnsDefault recTypeConName + [ ((nameBase n, ct), Nothing) | n <- ns | ct <- cts ]) + mayNs + pc <- defineProductConstructorInstance tyCon dataCon cts + return $ concat [pw, cs, pc] diff --git a/src/Database/Relational/Query/Table.hs b/src/Database/Relational/Query/Table.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Query/Table.hs @@ -0,0 +1,97 @@ +-- | +-- Module : Database.Relational.Query.Table +-- Copyright : 2013 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module defines table type which has table metadatas. +module Database.Relational.Query.Table ( + -- * Untyped table type + Untyped, name', width', columns', (!), + + -- * Phantom typed table type + Table, unType, name, shortName, width, columns, index, table, toMaybe, + + -- * Table existence inference + TableDerivable (..) + ) where + +import Data.Array (Array, listArray, elems) +import qualified Data.Array as Array + +import Database.Record (PersistableWidth) + +import Database.Relational.Query.Component (ColumnSQL, columnSQL) + + +-- | Untyped typed table type +data Untyped = Untyped String Int (Array Int ColumnSQL) deriving Show + +-- | Name string of table in SQL +name' :: Untyped -> String +name' (Untyped n _ _) = n + +-- | Width of table +width' :: Untyped -> Int +width' (Untyped _ w _) = w + +-- | Column name strings in SQL +columnArray :: Untyped -> Array Int ColumnSQL +columnArray (Untyped _ _ c) = c + +-- | Column name strings in SQL +columns' :: Untyped -> [ColumnSQL] +columns' = elems . columnArray + +-- | Column name string in SQL specified by index +(!) :: Untyped + -> Int -- ^ Column index + -> ColumnSQL -- ^ Column name String in SQL +t ! i = columnArray t Array.! i + + +-- | Phantom typed table type +newtype Table r = Table Untyped + +-- | Untype table. +unType :: Table t -> Untyped +unType (Table u) = u + +-- | Name string of table in SQL +name :: Table r -> String +name = name' . unType + +-- | Not qualified name string of table in SQL +shortName :: Table r -> String +shortName = tail . dropWhile (/= '.') . name + +-- | Width of table +width :: Table r -> Int +width = width' . unType + +-- | Column name strings in SQL +columns :: Table r -> [ColumnSQL] +columns = columns' . unType + +-- | Column name string in SQL specified by index +index :: Table r + -> Int -- ^ Column index + -> ColumnSQL -- ^ Column name String in SQL +index = (!) . unType + +-- | Cast phantom type into 'Maybe' type. +toMaybe :: Table r -> Table (Maybe r) +toMaybe (Table t) = Table t + +-- | Unsafely generate phantom typed table type. +table :: String -> [String] -> Table r +table n f = Table $ Untyped n w fa where + w = length f + fa = listArray (0, w - 1) $ map columnSQL f + +-- | Inference rule of 'Table' existence. +class PersistableWidth r => TableDerivable r where + derivedTable :: Table r diff --git a/src/Database/Relational/Query/Type.hs b/src/Database/Relational/Query/Type.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Query/Type.hs @@ -0,0 +1,265 @@ +-- | +-- Module : Database.Relational.Query.Type +-- Copyright : 2013 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module defines typed SQL. +module Database.Relational.Query.Type ( + -- * Typed query statement + Query (..), unsafeTypedQuery, + + relationalQuery', relationalQuery, + + relationalQuerySQL, + + -- * Typed update statement + KeyUpdate (..), unsafeTypedKeyUpdate, typedKeyUpdate, typedKeyUpdateTable, + Update (..), unsafeTypedUpdate, typedUpdate, typedUpdateTable, targetUpdate, targetUpdateTable, + typedUpdateAllColumn, restrictedUpdateAllColumn, restrictedUpdateTableAllColumn, + + updateSQL, + + -- * Typed insert statement + Insert (..), unsafeTypedInsert', unsafeTypedInsert, typedInsert', typedInsert, derivedInsert, + InsertQuery (..), unsafeTypedInsertQuery, typedInsertQuery, derivedInsertQuery, + + insertQuerySQL, + + -- * Typed delete statement + Delete (..), unsafeTypedDelete, typedDelete, restrictedDelete, + + deleteSQL, + + -- * Generalized interfaces + UntypeableNoFetch (..) + ) where + +import Data.Monoid ((<>)) + +import Database.Record (PersistableWidth) + +import Database.Relational.Query.Internal.SQL (showStringSQL) +import Database.Relational.Query.Relation (Relation, sqlFromRelationWith, tableOf) +import Database.Relational.Query.Effect + (Restriction, RestrictionContext, restriction', + UpdateTarget, UpdateTargetContext, updateTarget', liftTargetAllColumn', + sqlWhereFromRestriction, sqlFromUpdateTarget) +import Database.Relational.Query.Pi (Pi) +import qualified Database.Relational.Query.Pi as Pi +import Database.Relational.Query.Component (Config (chunksInsertSize), defaultConfig) +import Database.Relational.Query.Table (Table, TableDerivable, derivedTable) +import Database.Relational.Query.SQL + (QuerySuffix, showsQuerySuffix, insertPrefixSQL, insertSQL, insertSizedChunkSQL, + updateOtherThanKeySQL, updatePrefixSQL, deletePrefixSQL) + + +-- | Query type with place-holder parameter 'p' and query result type 'a'. +newtype Query p a = Query { untypeQuery :: String } + +-- | Unsafely make typed 'Query' from SQL string. +unsafeTypedQuery :: String -- ^ Query SQL to type + -> Query p a -- ^ Typed result +unsafeTypedQuery = Query + +-- | Show query SQL string +instance Show (Query p a) where + show = untypeQuery + +-- | From 'Relation' into untyped SQL query string. +relationalQuerySQL :: Config -> Relation p r -> QuerySuffix -> String +relationalQuerySQL config rel qsuf = showStringSQL $ sqlFromRelationWith rel config <> showsQuerySuffix qsuf + +-- | From 'Relation' into typed 'Query' with suffix SQL words. +relationalQuery' :: Relation p r -> QuerySuffix -> Query p r +relationalQuery' rel qsuf = unsafeTypedQuery $ relationalQuerySQL defaultConfig rel qsuf + +-- | From 'Relation' into typed 'Query'. +relationalQuery :: Relation p r -> Query p r +relationalQuery = (`relationalQuery'` []) + + +-- | Update type with key type 'p' and update record type 'a'. +-- Columns to update are record columns other than key columns, +-- So place-holder parameter type is the same as record type 'a'. +data KeyUpdate p a = KeyUpdate { updateKey :: Pi a p + , untypeKeyUpdate :: String + } + +-- | Unsafely make typed 'KeyUpdate' from SQL string. +unsafeTypedKeyUpdate :: Pi a p -> String -> KeyUpdate p a +unsafeTypedKeyUpdate = KeyUpdate + +-- | Make typed 'KeyUpdate' from 'Table' and key indexes. +typedKeyUpdate :: Table a -> Pi a p -> KeyUpdate p a +typedKeyUpdate tbl key = unsafeTypedKeyUpdate key $ updateOtherThanKeySQL tbl key + +-- | Make typed 'KeyUpdate' object using derived info specified by 'Relation' type. +typedKeyUpdateTable :: TableDerivable r => Relation () r -> Pi r p -> KeyUpdate p r +typedKeyUpdateTable = typedKeyUpdate . tableOf + +-- | Show update SQL string +instance Show (KeyUpdate p a) where + show = untypeKeyUpdate + + +-- | Update type with place-holder parameter 'p'. +newtype Update p = Update { untypeUpdate :: String } + +-- | Unsafely make typed 'Update' from SQL string. +unsafeTypedUpdate :: String -> Update p +unsafeTypedUpdate = Update + +-- | Make untyped update SQL string from 'Table' and 'Restriction'. +updateSQL :: Table r -> UpdateTarget p r -> String +updateSQL tbl ut = showStringSQL $ updatePrefixSQL tbl <> sqlFromUpdateTarget tbl ut + +-- | Make typed 'Update' from 'Table' and 'Restriction'. +typedUpdate :: Table r -> UpdateTarget p r -> Update p +typedUpdate tbl ut = unsafeTypedUpdate $ updateSQL tbl ut + +-- | Make typed 'Update' object using derived info specified by 'Relation' type. +typedUpdateTable :: TableDerivable r => Relation () r -> UpdateTarget p r -> Update p +typedUpdateTable = typedUpdate . tableOf + +-- | Directly make typed 'Update' from 'Table' and 'Target' monad context. +targetUpdate :: Table r + -> UpdateTargetContext p r -- ^ 'Target' monad context + -> Update p +targetUpdate tbl = typedUpdate tbl . updateTarget' + +-- | Directly make typed 'Update' from 'Relation' and 'Target' monad context. +targetUpdateTable :: TableDerivable r + => Relation () r + -> UpdateTargetContext p r -- ^ 'Target' monad context + -> Update p +targetUpdateTable = targetUpdate . tableOf + +-- | Make typed 'Update' from 'Table' and 'Restriction'. +-- Update target is all column. +typedUpdateAllColumn :: PersistableWidth r + => Table r + -> Restriction p r + -> Update (r, p) +typedUpdateAllColumn tbl r = typedUpdate tbl $ liftTargetAllColumn' r + +-- | Directly make typed 'Update' from 'Table' and 'Restrict' monad context. +-- Update target is all column. +restrictedUpdateAllColumn :: PersistableWidth r + => Table r + -> RestrictionContext p r -- ^ 'Restrict' monad context + -> Update (r, p) +restrictedUpdateAllColumn tbl = typedUpdateAllColumn tbl . restriction' + +-- | Directly make typed 'Update' from 'Table' and 'Restrict' monad context. +-- Update target is all column. +restrictedUpdateTableAllColumn :: (PersistableWidth r, TableDerivable r) + => Relation () r + -> RestrictionContext p r + -> Update (r, p) +restrictedUpdateTableAllColumn = restrictedUpdateAllColumn . tableOf + +-- | Show update SQL string +instance Show (Update p) where + show = untypeUpdate + + +-- | Insert type to insert record type 'a'. +data Insert a = + Insert + { untypeInsert :: String + , untypeChunkInsert :: String + , chunkSizeOfInsert :: Int + } + +-- | Unsafely make typed 'Insert' from single insert and chunked insert SQL. +unsafeTypedInsert' :: String -> String -> Int -> Insert a +unsafeTypedInsert' = Insert + +-- | Unsafely make typed 'Insert' from single insert SQL. +unsafeTypedInsert :: String -> Insert a +unsafeTypedInsert q = unsafeTypedInsert' q q 1 + +-- | Make typed 'Insert' from columns selector 'Pi' and 'Table'. +typedInsert' :: Config -> Pi r r' -> Table r -> Insert r' +typedInsert' config pi' tbl = unsafeTypedInsert' (insertSQL pi' tbl) ci n where + (ci, n) = insertSizedChunkSQL pi' tbl $ chunksInsertSize config + +-- | Make typed 'Insert' from columns selector 'Pi' and 'Table'. +typedInsert :: Pi r r' -> Table r -> Insert r' +typedInsert = typedInsert' defaultConfig + +-- | Infered 'Insert'. +derivedInsert :: TableDerivable r => Insert r +derivedInsert = typedInsert Pi.id' derivedTable + +-- | Show insert SQL string. +instance Show (Insert a) where + show = untypeInsert + +-- | InsertQuery type. +newtype InsertQuery p = InsertQuery { untypeInsertQuery :: String } + +-- | Unsafely make typed 'InsertQuery' from SQL string. +unsafeTypedInsertQuery :: String -> InsertQuery p +unsafeTypedInsertQuery = InsertQuery + +-- | Make untyped insert select SQL string from 'Table' and 'Relation'. +insertQuerySQL :: TableDerivable r => Config -> Pi r r' -> Relation p r' -> String +insertQuerySQL config pi' rel = showStringSQL $ insertPrefixSQL pi' derivedTable <> sqlFromRelationWith rel config + +-- | Make typed 'InsertQuery' from columns selector 'Pi' and 'Table' and 'Relation'. +typedInsertQuery :: TableDerivable r => Pi r r' -> Relation p r' -> InsertQuery p +typedInsertQuery pi' rel = unsafeTypedInsertQuery $ insertQuerySQL defaultConfig pi' rel + +-- | Infered 'InsertQuery'. +derivedInsertQuery :: TableDerivable r => Relation p r -> InsertQuery p +derivedInsertQuery = typedInsertQuery Pi.id' + +-- | Show insert SQL string. +instance Show (InsertQuery p) where + show = untypeInsertQuery + + +-- | Delete type with place-holder parameter 'p'. +newtype Delete p = Delete { untypeDelete :: String } + +-- | Unsafely make typed 'Delete' from SQL string. +unsafeTypedDelete :: String -> Delete p +unsafeTypedDelete = Delete + +-- | Make untyped delete SQL string from 'Table' and 'Restriction'. +deleteSQL :: Table r -> Restriction p r -> String +deleteSQL tbl r = showStringSQL $ deletePrefixSQL tbl <> sqlWhereFromRestriction tbl r + +-- | Make typed 'Delete' from 'Table' and 'Restriction'. +typedDelete :: Table r -> Restriction p r -> Delete p +typedDelete tbl r = unsafeTypedDelete $ deleteSQL tbl r + +-- | Directly make typed 'Delete' from 'Table' and 'Restrict' monad context. +restrictedDelete :: Table r + -> RestrictionContext p r -- ^ 'Restrict' monad context. + -> Delete p +restrictedDelete tbl = typedDelete tbl . restriction' + +-- | Show delete SQL string +instance Show (Delete p) where + show = untypeDelete + + +-- | Untype interface for typed no-result type statments +-- with single type parameter which represents place-holder parameter 'p'. +class UntypeableNoFetch s where + untypeNoFetch :: s p -> String + +instance UntypeableNoFetch Insert where + untypeNoFetch = untypeInsert + +instance UntypeableNoFetch Update where + untypeNoFetch = untypeUpdate + +instance UntypeableNoFetch Delete where + untypeNoFetch = untypeDelete diff --git a/test/Model.hs b/test/Model.hs new file mode 100644 --- /dev/null +++ b/test/Model.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Model where + +import Data.Int (Int32, Int64) + +import Database.Relational.Query (defaultConfig) +import Database.Relational.Query.TH (defineTableDefault, makeRelationalRecordDefault) + + +$(defineTableDefault defaultConfig "TEST" "set_a" + [ ("int_a0" , [t| Int32 |]) + , ("str_a1" , [t| String |]) + , ("str_a2" , [t| String |]) ] + [] [0] $ Just 0) + + +$(defineTableDefault defaultConfig "TEST" "set_b" + [ ("int_b0" , [t| Int32 |]) + , ("may_str_b1" , [t| Maybe String |]) + , ("str_b2" , [t| String |]) ] + [] [0] $ Just 0) + + +$(defineTableDefault defaultConfig "TEST" "set_c" + [ ("int_c0" , [t| Int32 |]) + , ("str_c1" , [t| String |]) + , ("int_c2" , [t| Int64 |]) + , ("may_str_c3" , [t| Maybe String |]) ] + [] [0] $ Just 0) + + +data ABC = + ABC + { xJustA :: SetA + , xJustB :: SetB + , xJustC :: SetC + } + +$(makeRelationalRecordDefault ''ABC) + +data Abc = + Abc + { yJustA :: SetA + , yMayB :: Maybe SetB + , yMayC :: Maybe SetC + } + +$(makeRelationalRecordDefault ''Abc) diff --git a/test/SQLs.hs b/test/SQLs.hs new file mode 100644 --- /dev/null +++ b/test/SQLs.hs @@ -0,0 +1,116 @@ +module SQLs (tests) where + +import Distribution.TestSuite (Test) + +import Tool (eqShow) +import Model + +import Data.Int (Int32) +import Database.Relational.Query + +base :: [Test] +base = + [ eqShow "setA" setA "SELECT int_a0, str_a1, str_a2 FROM TEST.set_a" + , eqShow "setB" setB "SELECT int_b0, may_str_b1, str_b2 FROM TEST.set_b" + , eqShow "setC" setC "SELECT int_c0, str_c1, int_c2, may_str_c3 FROM TEST.set_c" + ] + +_p_base :: IO () +_p_base = mapM_ print [show setA, show setB, show setC] + +cross :: Relation () (SetA, SetB) +cross = setA `inner` setB `on'` [] + +innerX :: Relation () (SetA, SetB) +innerX = setA `inner` setB `on'` [ \a b -> a ! intA0' .=. b ! intB0' ] + +leftX :: Relation () (SetA, Maybe SetB) +leftX = setA `left` setB `on'` [ \a b -> just (a ! strA1') .=. b ?!? mayStrB1' ] + +rightX :: Relation () (Maybe SetA, SetB) +rightX = setA `right` setB `on'` [ \a b -> a ?! intA0' .=. just (b ! intB0') ] + +fullX :: Relation () (Maybe SetA, Maybe SetB) +fullX = setA `full` setB `on'` [ \a b -> a ?! intA0' .=. b ?! intB0' ] + +directJoins :: [Test] +directJoins = + [ eqShow "cross" cross + "SELECT ALL T0.int_a0 AS f0, T0.str_a1 AS f1, T0.str_a2 AS f2, T1.int_b0 AS f3, T1.may_str_b1 AS f4, T1.str_b2 AS f5 FROM TEST.set_a T0 INNER JOIN TEST.set_b T1 ON (0=0)" + , eqShow "inner" innerX + "SELECT ALL T0.int_a0 AS f0, T0.str_a1 AS f1, T0.str_a2 AS f2, T1.int_b0 AS f3, T1.may_str_b1 AS f4, T1.str_b2 AS f5 FROM TEST.set_a T0 INNER JOIN TEST.set_b T1 ON (T0.int_a0 = T1.int_b0)" + , eqShow "left" leftX + "SELECT ALL T0.int_a0 AS f0, T0.str_a1 AS f1, T0.str_a2 AS f2, T1.int_b0 AS f3, T1.may_str_b1 AS f4, T1.str_b2 AS f5 FROM TEST.set_a T0 LEFT JOIN TEST.set_b T1 ON (T0.str_a1 = T1.may_str_b1)" + , eqShow "right" rightX + "SELECT ALL T0.int_a0 AS f0, T0.str_a1 AS f1, T0.str_a2 AS f2, T1.int_b0 AS f3, T1.may_str_b1 AS f4, T1.str_b2 AS f5 FROM TEST.set_a T0 RIGHT JOIN TEST.set_b T1 ON (T0.int_a0 = T1.int_b0)" + , eqShow "full" fullX + "SELECT ALL T0.int_a0 AS f0, T0.str_a1 AS f1, T0.str_a2 AS f2, T1.int_b0 AS f3, T1.may_str_b1 AS f4, T1.str_b2 AS f5 FROM TEST.set_a T0 FULL JOIN TEST.set_b T1 ON (T0.int_a0 = T1.int_b0)" + ] + +_p_directJoins :: IO () +_p_directJoins = mapM_ print [show cross, show innerX, show leftX, show rightX, show fullX] + + +j3left :: Relation () Abc +j3left = relation $ do + a <- query setA + b <- queryMaybe setB + on $ just (a ! strA2') .=. b ?! strB2' + c <- queryMaybe setC + on $ b ?! intB0' .=. c ?! intC0' + + return $ Abc |$| a |*| b |*| c + +j3right :: Relation () Abc +j3right = relation $ do + a <- query setA + bc <- query $ setB `full` setC `on'` [ \b c -> b ?! intB0' .=. c ?! intC0' ] + let b = bc ! fst' + c = bc ! snd' + on $ just (a ! strA2') .=. b ?! strB2' + + return $ Abc |$| a |*| b |*| c + +join3s :: [Test] +join3s = [ eqShow "join-3 left" j3left + "SELECT ALL T0.int_a0 AS f0, T0.str_a1 AS f1, T0.str_a2 AS f2, T1.int_b0 AS f3, T1.may_str_b1 AS f4, T1.str_b2 AS f5, T2.int_c0 AS f6, T2.str_c1 AS f7, T2.int_c2 AS f8, T2.may_str_c3 AS f9 FROM (TEST.set_a T0 LEFT JOIN TEST.set_b T1 ON (T0.str_a2 = T1.str_b2)) LEFT JOIN TEST.set_c T2 ON (T1.int_b0 = T2.int_c0)" + + , eqShow "join-3 right" j3right + "SELECT ALL T0.int_a0 AS f0, T0.str_a1 AS f1, T0.str_a2 AS f2, T3.f0 AS f3, T3.f1 AS f4, T3.f2 AS f5, T3.f3 AS f6, T3.f4 AS f7, T3.f5 AS f8, T3.f6 AS f9 FROM TEST.set_a T0 INNER JOIN (SELECT ALL T1.int_b0 AS f0, T1.may_str_b1 AS f1, T1.str_b2 AS f2, T2.int_c0 AS f3, T2.str_c1 AS f4, T2.int_c2 AS f5, T2.may_str_c3 AS f6 FROM TEST.set_b T1 FULL JOIN TEST.set_c T2 ON (T1.int_b0 = T2.int_c0)) T3 ON (T0.str_a2 = T3.f2)" + ] + +_p_j3s :: IO () +_p_j3s = mapM_ print [show j3left, show j3right] + +justX :: Relation () (SetA, Maybe SetB) +justX = relation $ do + a <- query setA + b <- queryMaybe setB + + wheres $ isJust b `or'` a ! intA0' .=. value 1 + + return $ a >< b + +maybeX :: Relation () (Int32, SetB) +maybeX = relation $ do + a <- queryMaybe setA + b <- query setB + + wheres $ a ?! strA2' .=. b ! mayStrB1' + + return $ fromMaybe' (value 1) (a ?! intA0') >< b + +maybes :: [Test] +maybes = [ eqShow "isJust" justX + "SELECT ALL T0.int_a0 AS f0, T0.str_a1 AS f1, T0.str_a2 AS f2, T1.int_b0 AS f3, T1.may_str_b1 AS f4, T1.str_b2 AS f5 FROM TEST.set_a T0 LEFT JOIN TEST.set_b T1 ON (0=0) WHERE ((NOT (T1.int_b0 IS NULL)) OR (T0.int_a0 = 1))" + , eqShow "fromMaybe" maybeX + "SELECT ALL CASE WHEN (T0.int_a0 IS NULL) THEN 1 ELSE T0.int_a0 END AS f0, T1.int_b0 AS f1, T1.may_str_b1 AS f2, T1.str_b2 AS f3 FROM TEST.set_a T0 RIGHT JOIN TEST.set_b T1 ON (0=0) WHERE (T0.str_a2 = T1.may_str_b1)" + ] + +_p_maybes :: IO () +_p_maybes = mapM_ print [show justX, show maybeX] + + +tests :: IO [Test] +tests = + return $ concat [base, directJoins, join3s, maybes] diff --git a/test/Tool.hs b/test/Tool.hs new file mode 100644 --- /dev/null +++ b/test/Tool.hs @@ -0,0 +1,48 @@ +module Tool ( + prop, + eq, + eqShow, + ) where + +-- import Control.Exception (try) + +import Distribution.TestSuite + (Test (Test), TestInstance (TestInstance), + Result (Pass, Fail), Progress (Finished)) + + +noOption :: String -> IO Progress -> Test +noOption name p = Test this where + this = TestInstance p name [] [] (\_ _ -> Right this) + +simple :: String -> IO Result -> Test +simple name = noOption name . fmap Finished + + +boolResult :: Bool -> String -> Result +boolResult b msg + | b = Pass + | otherwise = Fail msg + +prop :: String -> Bool -> String -> Test +prop name b = simple name . return . boolResult b + +eq :: Eq b => String -> (a -> b) -> a -> b -> String -> Test +eq name t x est = prop name (t x == est) + +eqShow :: Show a => String -> a -> String -> Test +eqShow name x est = + eq name show x est $ unwords [show x, "/=", est] + +{- +boolIoResult :: IO Bool -> String -> IO Result +boolIoResult iob msg = do + eb <- try iob + return $ case eb :: Either IOError Bool of + Right True -> Pass + Right False -> Fail msg + Left e -> Error $ show e + +propIO :: String -> IO Bool -> String -> Test +propIO name iob = simple name . boolIoResult iob + -}