packages feed

relational-query (empty) → 0.0.1.0

raw patch · 44 files changed

+5629/−0 lines, 44 filesdep +Cabaldep +arraydep +basesetup-changed

Dependencies added: Cabal, array, base, bytestring, containers, dlist, names-th, old-locale, persistable-record, relational-query, sql-words, template-haskell, text, time, transformers

Files

+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ relational-query.cabal view
@@ -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
+ src/Database/Relational/Query.hs view
@@ -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" #-}
+ src/Database/Relational/Query/Component.hs view
@@ -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)
+ src/Database/Relational/Query/Constraint.hs view
@@ -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
+ src/Database/Relational/Query/Context.hs view
@@ -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
+ src/Database/Relational/Query/Derives.hs view
@@ -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 <table> 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
+ src/Database/Relational/Query/Effect.hs view
@@ -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))
+ src/Database/Relational/Query/Expr.hs view
@@ -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)
+ src/Database/Relational/Query/Expr/Unsafe.hs view
@@ -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
+ src/Database/Relational/Query/Internal/Product.hs view
@@ -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)
+ src/Database/Relational/Query/Internal/SQL.hs view
@@ -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
+ src/Database/Relational/Query/Monad/Aggregate.hs view
@@ -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
+ src/Database/Relational/Query/Monad/Assign.hs view
@@ -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
+ src/Database/Relational/Query/Monad/Class.hs view
@@ -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
+ src/Database/Relational/Query/Monad/Restrict.hs view
@@ -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
+ src/Database/Relational/Query/Monad/Simple.hs view
@@ -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
+ src/Database/Relational/Query/Monad/Trans/Aggregating.hs view
@@ -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
+ src/Database/Relational/Query/Monad/Trans/Assigning.hs view
@@ -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
+ src/Database/Relational/Query/Monad/Trans/Config.hs view
@@ -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
+ src/Database/Relational/Query/Monad/Trans/Join.hs view
@@ -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)
+ src/Database/Relational/Query/Monad/Trans/JoinState.hs view
@@ -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
+ src/Database/Relational/Query/Monad/Trans/Ordering.hs view
@@ -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
+ src/Database/Relational/Query/Monad/Trans/Qualify.hs view
@@ -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
+ src/Database/Relational/Query/Monad/Trans/Restricting.hs view
@@ -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
+ src/Database/Relational/Query/Monad/Type.hs view
@@ -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
+ src/Database/Relational/Query/Monad/Unique.hs view
@@ -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 []
+ src/Database/Relational/Query/Pi.hs view
@@ -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
+ src/Database/Relational/Query/Pi/Unsafe.hs view
@@ -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
+ src/Database/Relational/Query/Projectable.hs view
@@ -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 /</ .+(.<.)  :: (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..>=.)++-- | 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 <when list> `casesOrElse` <else clause>.+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'` <else clause>.+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  ><
+ src/Database/Relational/Query/ProjectableExtended.hs view
@@ -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 >?<
+ src/Database/Relational/Query/Projection.hs view
@@ -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
+ src/Database/Relational/Query/Pure.hs view
@@ -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
+ src/Database/Relational/Query/Relation.hs view
@@ -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'
+ src/Database/Relational/Query/SQL.hs view
@@ -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
+ src/Database/Relational/Query/Scalar.hs view
@@ -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) |]
+ src/Database/Relational/Query/Sub.hs view
@@ -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!"
+ src/Database/Relational/Query/TH.hs view
@@ -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]
+ src/Database/Relational/Query/Table.hs view
@@ -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
+ src/Database/Relational/Query/Type.hs view
@@ -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
+ test/Model.hs view
@@ -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)
+ test/SQLs.hs view
@@ -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]
+ test/Tool.hs view
@@ -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+ -}