haskelldb 0.13 → 2.2.4
raw patch · 21 files changed
Files
- LICENSE +31/−0
- haskelldb.cabal +50/−40
- src/Database/HaskellDB.hs +37/−36
- src/Database/HaskellDB/BoundedList.hs +7/−1
- src/Database/HaskellDB/DBDirect.hs +9/−7
- src/Database/HaskellDB/DBLayout.hs +21/−18
- src/Database/HaskellDB/DBSpec/DBInfo.hs +4/−3
- src/Database/HaskellDB/DBSpec/DBSpecToDBDirect.hs +21/−18
- src/Database/HaskellDB/DBSpec/DatabaseToDBSpec.hs +1/−1
- src/Database/HaskellDB/Database.hs +34/−20
- src/Database/HaskellDB/DriverAPI.hs +1/−0
- src/Database/HaskellDB/FieldType.hs +12/−8
- src/Database/HaskellDB/HDBRec.hs +8/−5
- src/Database/HaskellDB/Optimize.hs +71/−58
- src/Database/HaskellDB/PrimQuery.hs +12/−6
- src/Database/HaskellDB/PrintQuery.hs +144/−130
- src/Database/HaskellDB/Query.hs +142/−120
- src/Database/HaskellDB/Sql.hs +61/−4
- src/Database/HaskellDB/Sql/Default.hs +155/−82
- src/Database/HaskellDB/Sql/PostgreSQL.hs +0/−4
- src/Database/HaskellDB/Sql/Print.hs +8/−6
+ LICENSE view
@@ -0,0 +1,31 @@+Copyright (c) 1999 Daan Leijen, daan@cs.uu.nl+Copyright (c) 2003-2004 The HaskellDB development team+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 names of the copyright holders nor the names of the+ 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.
haskelldb.cabal view
@@ -1,23 +1,30 @@ Name: haskelldb-Version: 0.13-Cabal-version: >= 1.2+Version: 2.2.4+Cabal-version: >= 1.6 Build-type: Simple-Homepage: http://haskelldb.sourceforge.net+Homepage: https://github.com/m4dc4p/haskelldb Copyright: The authors Maintainer: "Justin Bailey" <jgbailey@gmail.com>-Author: Daan Leijen, Conny Andersson, Martin Andersson, Mary Bergman, Victor Blomqvist, Bjorn Bringert, Anders Hockersten, Torbjorn Martin, Jeremy Shaw+Author: Daan Leijen, Conny Andersson, Martin Andersson, Mary Bergman, Victor Blomqvist, Bjorn Bringert, Anders Hockersten, Torbjorn Martin, Jeremy Shaw, Justin Bailey License: BSD3-Synopsis: SQL unwrapper for Haskell.--Flag split-base+License-file: LICENSE+Synopsis: A library of combinators for generating and executing SQL statements.+Description: This library allows you to build SQL SELECT, INSERT, UPDATE, and DELETE + statements using operations based on the relational algebra. +Category: Database Library- Build-depends: mtl >= 1 && < 2- if flag(split-base)- Build-depends: base >= 3 && < 5, pretty >= 1 && < 2, old-time >= 1 && < 2, old-locale >= 1 && < 2, directory >= 1 && < 2- else- Build-depends: base < 3+ Build-depends: mtl >= 1.1 && < 3, + base >= 3 && < 5, + pretty >= 1 && < 2, + old-time >= 1 && < 2, + old-locale >= 1 && < 2, + directory >= 1 && < 2,+ containers >= 0.3 && < 1,+ time >= 1.0 Extensions:+ EmptyDataDecls,+ DeriveDataTypeable, ExistentialQuantification, OverlappingInstances, UndecidableInstances,@@ -28,32 +35,35 @@ FlexibleContexts, PolymorphicComponents Exposed-Modules:- Database.HaskellDB,- Database.HaskellDB.BoundedList,- Database.HaskellDB.BoundedString,- Database.HaskellDB.DBLayout,- Database.HaskellDB.DBDirect,- Database.HaskellDB.DBSpec,- Database.HaskellDB.DBSpec.DBInfo,- Database.HaskellDB.DBSpec.DBSpecToDBDirect,- Database.HaskellDB.DBSpec.DBSpecToDatabase,- Database.HaskellDB.DBSpec.DatabaseToDBSpec,- Database.HaskellDB.DBSpec.PPHelpers,- Database.HaskellDB.Database,- Database.HaskellDB.FieldType,- Database.HaskellDB.HDBRec,- Database.HaskellDB.Optimize,- Database.HaskellDB.PrimQuery,- Database.HaskellDB.PrintQuery,- Database.HaskellDB.Query,- Database.HaskellDB.Sql,- Database.HaskellDB.Sql.Generate,- Database.HaskellDB.Sql.Default,- Database.HaskellDB.Sql.Print,- Database.HaskellDB.Sql.MySQL,- Database.HaskellDB.Sql.PostgreSQL,- Database.HaskellDB.Sql.SQLite,- Database.HaskellDB.Version,- Database.HaskellDB.DriverAPI+ Database.HaskellDB,+ Database.HaskellDB.BoundedList,+ Database.HaskellDB.BoundedString,+ Database.HaskellDB.DBLayout,+ Database.HaskellDB.DBDirect,+ Database.HaskellDB.DBSpec,+ Database.HaskellDB.DBSpec.DBInfo,+ Database.HaskellDB.DBSpec.DBSpecToDBDirect,+ Database.HaskellDB.DBSpec.DBSpecToDatabase,+ Database.HaskellDB.DBSpec.DatabaseToDBSpec,+ Database.HaskellDB.DBSpec.PPHelpers,+ Database.HaskellDB.Database,+ Database.HaskellDB.FieldType,+ Database.HaskellDB.Optimize,+ Database.HaskellDB.PrimQuery,+ Database.HaskellDB.PrintQuery,+ Database.HaskellDB.Query,+ Database.HaskellDB.HDBRec,+ Database.HaskellDB.Sql,+ Database.HaskellDB.Sql.Generate,+ Database.HaskellDB.Sql.Default,+ Database.HaskellDB.Sql.Print,+ Database.HaskellDB.Sql.MySQL,+ Database.HaskellDB.Sql.PostgreSQL,+ Database.HaskellDB.Sql.SQLite,+ Database.HaskellDB.Version,+ Database.HaskellDB.DriverAPI Hs-source-dirs: src- ghc-options: -O2++Source-repository head+ Type: git+ Location: https://github.com/m4dc4p/haskelldb
src/Database/HaskellDB.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE FlexibleInstances #-} ----------------------------------------------------------- -- | -- Module : HaskellDB@@ -39,49 +40,46 @@ -- ----------------------------------------------------------- module Database.HaskellDB- ( Rel, Attr, Expr, ExprAggr, Table, Query, OrderExpr-- -- * Records- , HasField, Record, Select, ( # ), ( << ), (<<-), (!), (!.)- - -- * Relational operators- , restrict, table, project, unique- , union, intersect, divide, minus-- -- * Query expressions- , (.==.) , (.<>.), (.<.), (.<=.), (.>.), (.>=.)- , (.&&.) , (.||.)- , (.*.) , (./.), (.%.), (.+.), (.-.), (.++.)- , _not, like, _in, cat, _length- , isNull, notNull, fromNull- , constant, constJust- , param, namedParam, Args, func- , queryParams, Param- - , count, _sum, _max, _min, avg- , stddev, stddevP, variance, varianceP- - , asc, desc, order- , top --, topPercent+ ( Rel, Attr, Expr, ExprAggr, Table, Query, OrderExpr+ -- * Records+ , HasField, Record, Select, ( # ), ( << ), (<<-), (!), (!.) - , _case- , _default+ -- * Relational operators+ , restrict, table, project, unique+ , union, intersect, divide, minus+ , copy, copyAll, subQuery - -- * Database operations- , Database -- abstract- , query- , insert, delete, update, insertQuery- , tables, describe, transaction+ -- * Query expressions+ , (.==.) , (.<>.), (.<.), (.<=.), (.>.), (.>=.)+ , (.&&.) , (.||.)+ , (.*.) , (./.), (.+.), (.-.), (.%.), (.++.)+ , _not, like, _in, cat, _length+ , isNull, notNull, fromNull, fromVal+ , constant, constVal, constNull, constExpr+ , param, namedParam, Args, func+ , queryParams, Param, cast, coerce+ , literal, toStr+ , count, _sum, _max, _min, avg+ , stddev, stddevP, variance, varianceP+ , asc, desc, order+ , top, offset, _case , _default - -- * Debugging- , showQuery, showQueryUnOpt, showSql, showSqlUnOpt- ) where+ -- * Database operations+ , Database -- abstract+ , query, recCat+ , insert, delete, update, insertQuery+ , tables, describe, transaction+ + -- * Debugging+ , showQuery, showQueryUnOpt, showSql, showSqlUnOpt+ ) where import Database.HaskellDB.HDBRec+ -- PrimQuery type is imported so that haddock can find it. import Database.HaskellDB.PrimQuery (PrimQuery) import Database.HaskellDB.Sql (SqlSelect(SqlSelect, SqlBin), SqlExpr(..), SqlName)-import qualified Database.HaskellDB.Sql as S (SqlSelect(..))+import qualified Database.HaskellDB.Sql as S (SqlSelect(..), Mark(..)) import Database.HaskellDB.Sql.Generate (sqlQuery) import Database.HaskellDB.Sql.Default (defaultSqlGenerator) import Database.HaskellDB.Sql.Print (ppSql)@@ -134,7 +132,9 @@ attrParams = getParams (exprParams . snd) tableParams = getParams (selectParams . snd) criteriaParams = getParams exprParams- groupByParams = getParams (exprParams . snd) + groupByParams Nothing = [] + groupByParams (Just S.All) = []+ groupByParams (Just (S.Columns cols)) = getParams (exprParams . snd) cols orderByParams = getParams (exprParams . fst) getParams :: (a -> [Maybe SqlName]) -> [a] -> [Maybe SqlName] getParams f = concatMap f@@ -148,6 +148,7 @@ exprParams (PrefixSqlExpr _ e) = exprParams e exprParams (PostfixSqlExpr _ e) = exprParams e exprParams (FunSqlExpr _ es) = (concatMap exprParams es)+ exprParams (AggrFunSqlExpr _ es) = (concatMap exprParams es) exprParams (CaseSqlExpr es e) = let caseExprs = concatMap (\(l, r) -> exprParams l ++ exprParams r) es in caseExprs ++ exprParams e
src/Database/HaskellDB/BoundedList.hs view
@@ -1,3 +1,6 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances+, FlexibleContexts, UndecidableInstances #-}+ ----------------------------------------------------------- -- | -- Module : BoundedList@@ -76,7 +79,9 @@ N240, N241, N242, N243, N244, N245, N246, N247, N248, N249, N250, N251, N252, N253, N254, N255, N65535) where- ++import Data.Typeable+ class Size n where size :: n -> Int @@ -1369,6 +1374,7 @@ instance Less a N255 => Less a N65535 newtype BoundedList a n = L [a]+ deriving (Typeable) instance (Show a, Size n) => Show (BoundedList a n) where show l@(L xs) = show xs
src/Database/HaskellDB/DBDirect.hs view
@@ -22,7 +22,7 @@ import Database.HaskellDB (Database, ) import Database.HaskellDB.DriverAPI (DriverInterface, connect, requiredOptions, )-import Database.HaskellDB.DBSpec (dbToDBSpec, )+import Database.HaskellDB.DBSpec (dbToDBSpec, dbname) import Database.HaskellDB.DBSpec.DBSpecToDBDirect (dbInfoToModuleFiles, ) import qualified Database.HaskellDB.DBSpec.PPHelpers as PP@@ -37,13 +37,13 @@ import Data.List (intersperse, ) -createModules :: String -> Bool -> PP.MakeIdentifiers -> Database -> IO ()-createModules m useBStrT mkIdent db =+createModules :: String -> String -> Bool -> PP.MakeIdentifiers -> Database -> IO ()+createModules m dbName useBStrT mkIdent db = do putStrLn "Getting database info..." spec <- dbToDBSpec useBStrT mkIdent m db putStrLn "Writing modules..."- dbInfoToModuleFiles "." m spec+ dbInfoToModuleFiles "." m (spec {dbname = dbName}) data Flags =@@ -108,11 +108,11 @@ case modAndDrvOpts of [] -> exitWithError "Missing module and driver options" [_] -> exitWithError "Missing driver options"- [moduleName,drvOpts] ->+ [moduleName,dbname,drvOpts] -> do putStrLn "Connecting to database..." connect driver (splitOptions drvOpts)- (createModules moduleName+ (createModules moduleName dbname (optBoundedStrings flags) (optIdentifierStyle flags)) putStrLn "Done!"@@ -138,8 +138,10 @@ showHelp driver = do p <- getProgName let header =- "Usage: " ++ p ++ " [dbdirect-options] <module> <driver-options>\n"+ "Usage: " ++ p ++ " [dbdirect-options] <module> <db-name> <driver-options>\n" footer = unlines $+ "" :+ "NOTE: You will probably have to specify the db name in both <driver-options> and <db-name>. This is because the driver options are specific to each database." : "" : "module: Module name without an extension" : ("driver-options: " ++
src/Database/HaskellDB/DBLayout.hs view
@@ -15,32 +15,35 @@ ----------------------------------------------------------- module Database.HaskellDB.DBLayout- (- module Database.HaskellDB.BoundedString,- module Database.HaskellDB.DBSpec,- CalendarTime,- Expr, Table, Attr, baseTable,- RecCons,RecNil,FieldTag,fieldName,- hdbMakeEntry,mkAttr,( # ))- where+ (module Database.HaskellDB.BoundedString+ , module Database.HaskellDB.DBSpec+ , CalendarTime, LocalTime+ , Expr, Table, Attr, baseTable+ , RecCons, RecNil, FieldTag, fieldName+ , hdbMakeEntry, mkAttr, ( # )+ , emptyTable) -import Database.HaskellDB.HDBRec(Record, RecCons, RecNil, FieldTag,- fieldName,( # ))+where++import Database.HaskellDB.HDBRec(Record, RecCons, RecNil, FieldTag+ , fieldName, ( # ))+ import Database.HaskellDB.BoundedString import System.Time (CalendarTime)-import Database.HaskellDB.Query (Expr, Table, Attr(..), - baseTable, attribute, (<<))+import Data.Time.LocalTime (LocalTime)+import Database.HaskellDB.Query (Expr, Table, Attr(..)+ , baseTable, attribute, (<<), emptyTable) import Database.HaskellDB.DBSpec import Database.HaskellDB.FieldType (FieldType(..)) -- | Constructs a table entry from a field tag-hdbMakeEntry :: FieldTag f => - f -- ^ Field tag- -> Record (RecCons f (Expr a) RecNil)+hdbMakeEntry :: FieldTag f =>+ f -- ^ Field tag+ -> Record (RecCons f (Expr a) RecNil) hdbMakeEntry f = undefined << attribute (fieldName f) -- | Make an 'Attr' for a field.-mkAttr :: FieldTag f => - f -- ^ Field tag- -> Attr f a+mkAttr :: FieldTag f =>+ f -- ^ Field tag+ -> Attr f a mkAttr = Attr . fieldName
src/Database/HaskellDB/DBSpec/DBInfo.hs view
@@ -22,7 +22,7 @@ import qualified Database.HaskellDB.DBSpec.PPHelpers as PP import Database.HaskellDB.FieldType (FieldDesc, FieldType(BStrT, StringT), )-import Data.Char (toLower, )+import Data.Char (toLower, isAlpha) import Text.PrettyPrint.HughesPJ -- | Defines a database layout, top level@@ -57,10 +57,11 @@ -- | Creates a valid declaration of a DBInfo. The variable name will be the -- same as the database name dbInfoToDoc :: DBInfo -> Doc-dbInfoToDoc dbi@(DBInfo {dbname=n}) +dbInfoToDoc dbi@(DBInfo {dbname = n+ , opts = opt}) = fixedName <+> text ":: DBInfo" $$ fixedName <+> equals <+> ppDBInfo dbi- where fixedName = text ((toLower . head) n : tail n)+ where fixedName = text . PP.identifier (makeIdent opt) $ n -- | Pretty prints a DBInfo ppDBInfo :: DBInfo -> Doc
src/Database/HaskellDB/DBSpec/DBSpecToDBDirect.hs view
@@ -39,12 +39,15 @@ header :: Doc header = ppComment ["Generated by DB/Direct"] +-- | Adds LANGUAGE pragrams to the top of generated files+languageOptions :: Doc+languageOptions = text "{-# LANGUAGE EmptyDataDecls, TypeSynonymInstances #-}"+ -- | Adds an appropriate -fcontext-stackXX OPTIONS pragma at the top -- of the generated file. contextStackPragma :: TInfo -> Doc contextStackPragma ti- = text "{-# OPTIONS_GHC" <+> text flag <+> text "#-}" $$- text "-- NOTE: use GHC flag" <+> text flag <+> text "with this module if GHC < 6.8.1"+ = text "{-# OPTIONS_GHC" <+> text flag <+> text "#-}" where flag = "-fcontext-stack" ++ (show (40 + length (cols ti))) -- | All imports generated files have dependencies on. Nowadays, this@@ -136,6 +139,7 @@ -> (String,Doc) -- ^ Module name and module contents tInfoToModule mi dbname tinfo@TInfo{tname=name,cols=col} = (modname,+ languageOptions $$ contextStackPragma tinfo $$ header $$ text "module" <+> text modname <+> text "where"@@ -165,17 +169,16 @@ ppTable :: MakeIdentifiers -> TInfo -> Doc ppTable mi (TInfo tiName tiColumns) = hang (text (identifier mi tiName) <+> text "::" <+> text "Table") 4- (text (toType mi tiName) <> newline)+ (text (toType mi tiName)) $$ text (identifier mi tiName) <+> text "=" <+> hang (text "baseTable" <+>- doubleQuotes (text (checkChars tiName)) <+>- text "$") 0- (vcat $ punctuate (text " #") (map (ppColumnValue mi) tiColumns))- <> newline+ doubleQuotes (text (checkChars tiName)) <+>+ text "$") 0+ (vcat $ punctuate (text " #") (map (ppColumnValue mi) tiColumns))+ <> newline -- | Pretty prints a list of ColumnInfo-ppColumns :: MakeIdentifiers -> [CInfo] -> Doc ppColumns _ [] = text "" ppColumns mi [c] = parens (ppColumnType mi c <+> text "RecNil") ppColumns mi (c:cs) = parens (ppColumnType mi c $$ ppColumns mi cs)@@ -184,19 +187,20 @@ ppColumnType :: MakeIdentifiers -> CInfo -> Doc ppColumnType mi (CInfo ciName (ciType,ciAllowNull)) = text "RecCons" <+>- ((text $ toType mi ciName) <+> parens (text "Expr"- <+> (if (ciAllowNull)- then parens (text "Maybe" <+> text (toHaskellType ciType))- else text (toHaskellType ciType)- )))+ ((text $ toType mi ciName) <+> + parens (text "Expr" <+> + (if (ciAllowNull)+ then parens (text "Maybe" <+> text (toHaskellType ciType))+ else text (toHaskellType ciType)+ ))) -- | Pretty prints the value field in a ColumnInfo ppColumnValue :: MakeIdentifiers -> CInfo -> Doc ppColumnValue mi (CInfo ciName _)- = text "hdbMakeEntry" <+> text (toType mi ciName)+ = text "hdbMakeEntry" <+> text (toType mi ciName) -- | Pretty prints Field definitions-ppField :: MakeIdentifiers -> (String,String) -> Doc+ppField :: MakeIdentifiers -> (String, String) -> Doc ppField mi (name,typeof) = ppComment [toType mi name ++ " Field"] <> newline $$@@ -206,14 +210,13 @@ (text "fieldName _" <+> equals <+> doubleQuotes (text (checkChars name))) <> newline $$- iname <+> text "::" <+> text "Attr" <+> bname <+> text typeof $$ iname <+> equals <+> text "mkAttr" <+> bname <> newline where- bname = text (toType mi name)- iname = text (identifier mi name)+ bname = text (toType mi name)+ iname = text (identifier mi name) -- | Extracts all the column names from a TableInfo columnNames :: TInfo -> [String]
src/Database/HaskellDB/DBSpec/DatabaseToDBSpec.hs view
@@ -17,7 +17,7 @@ (dbToDBSpec) where -import Database.HaskellDB (Database, tables, describe, )+import Database.HaskellDB.Database (Database, tables, describe, ) import Database.HaskellDB.DBSpec.DBInfo (DBInfo, makeCInfo, makeTInfo, makeDBSpec, DBOptions(DBOptions), useBString, makeIdent, )
src/Database/HaskellDB/Database.hs view
@@ -1,3 +1,7 @@+{-# LANGUAGE ExistentialQuantification, MultiParamTypeClasses+ , FunctionalDependencies, Rank2Types+ , FlexibleInstances, UndecidableInstances+ , TypeSynonymInstances, FlexibleContexts, ScopedTypeVariables #-} ----------------------------------------------------------- -- | -- Module : Database@@ -16,31 +20,32 @@ -- ----------------------------------------------------------- module Database.HaskellDB.Database ( - -- * Operators- (!.)+ -- * Operators+ (!.) -- * Type declarations , Database(..) , GetRec(..), GetInstances(..)-+ , GetValue(..) -- * Function declarations , query , insert, delete, update, insertQuery- , tables, describe, transaction+ , tables, describe, transaction, commit , createDB, createTable, dropDB, dropTable ) where -import Database.HaskellDB.HDBRec import Database.HaskellDB.FieldType import Database.HaskellDB.PrimQuery import Database.HaskellDB.Optimize (optimize, optimizeCriteria) import Database.HaskellDB.Query import Database.HaskellDB.BoundedString import Database.HaskellDB.BoundedList+import Database.HaskellDB.HDBRec import System.Time+import Data.Time.LocalTime import Control.Monad -infix 9 !. +infix 9 !. -- | The (!.) operator selects over returned records from -- the database (= rows)@@ -72,6 +77,7 @@ , dbCreateTable :: TableName -> [(Attribute,FieldDesc)] -> IO () , dbDropDB :: String -> IO () , dbDropTable :: TableName -> IO ()+ , dbCommit :: IO () } @@ -98,26 +104,27 @@ , getBool :: s -> String -> IO (Maybe Bool) -- | Get a 'CalendarTime' value. , getCalendarTime :: s -> String -> IO (Maybe CalendarTime)+ -- | Get a 'LocalTime' value.+ , getLocalTime :: s -> String -> IO (Maybe LocalTime) } class GetRec er vr | er -> vr, vr -> er where -- | Create a result record.- getRec :: GetInstances s -- ^ Driver functions for getting values- -- of different types.- -> Rel er -- ^ Phantom argument to the the return type right+ getRec :: GetInstances s -- ^ Driver functions for getting values+ -- of different types.+ -> Rel er -- ^ Phantom argument to the the return type right -> Scheme -- ^ Fields to get. -> s -- ^ Driver-specific result data -- (for example a Statement object) -> IO (Record vr) -- ^ Result record. instance GetRec RecNil RecNil where- -- NOTE: we accept extra fields, since the hacks in Optimzie could add fields that we don't want+ -- NOTE: we accept extra fields, since the hacks in Optimize could add fields that we don't want getRec _ _ _ _ = return emptyRecord -instance (GetValue a, GetRec er vr) +instance (GetValue a, GetRec er vr) => GetRec (RecCons f (Expr a) er) (RecCons f a vr) where- getRec _ _ [] _ = fail $ "Wanted non-empty record, but scheme is empty" getRec vfs c (f:fs) stmt = do@@ -140,6 +147,7 @@ instance GetValue Double where getValue = getNonNull instance GetValue Bool where getValue = getNonNull instance GetValue CalendarTime where getValue = getNonNull+instance GetValue LocalTime where getValue = getNonNull instance Size n => GetValue (BoundedString n) where getValue = getNonNull instance GetValue (Maybe String) where getValue = getString@@ -148,6 +156,7 @@ instance GetValue (Maybe Double) where getValue = getDouble instance GetValue (Maybe Bool) where getValue = getBool instance GetValue (Maybe CalendarTime) where getValue = getCalendarTime+instance GetValue (Maybe LocalTime) where getValue = getLocalTime instance Size n => GetValue (Maybe (BoundedString n)) where getValue fs s f = liftM (liftM trunc) (getValue fs s f) @@ -177,14 +186,14 @@ -- | Inserts a record into a table insert :: (ToPrimExprs r, ShowRecRow r, InsertRec r er) => Database -> Table er -> Record r -> IO ()-insert db (Table name assoc) newrec - = dbInsert db name (zip (attrs assoc) (exprs newrec))- where- attrs = map (\(attr,AttrExpr name) -> name)- +insert db (Table name assoc) newrec+ = dbInsert db name (zip (attrs assoc) (exprs newrec))+ where+ attrs = map (\(attr,AttrExpr name) -> name)+ -- | deletes a bunch of records -delete :: ShowRecRow r => - Database -- ^ The database+delete :: ShowRecRow r =>+ Database -- ^ The database -> Table r -- ^ The table to delete records from -> (Rel r -> Expr Bool) -- ^ Predicate used to select records to delete -> IO ()@@ -196,7 +205,7 @@ -- | Updates records update :: (ShowLabels s, ToPrimExprs s) =>- Database -- ^ The database+ Database -- ^ The database -> Table r -- ^ The table to update -> (Rel r -> Expr Bool) -- ^ Predicate used to select records to update -> (Rel r -> Record s) -- ^ Function used to modify selected records@@ -235,6 +244,11 @@ -> IO a -- ^ Action to run -> IO a transaction = dbTransaction++-- | Commit any pending data to the database.+commit :: Database -- ^ Database+ -> IO ()+commit = dbCommit ----------------------------------------------------------- -- Functions that edit the database layout
src/Database/HaskellDB/DriverAPI.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ExistentialQuantification, Rank2Types #-} ----------------------------------------------------------- -- | -- Module : DriverAPI
src/Database/HaskellDB/FieldType.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE FlexibleContexts, UndecidableInstances, TypeSynonymInstances, FlexibleInstances+ , MultiParamTypeClasses, StandaloneDeriving #-} ----------------------------------------------------------- -- | -- Module : FieldType@@ -15,13 +17,14 @@ ----------------------------------------------------------- module Database.HaskellDB.FieldType (FieldDesc, FieldType(..), toHaskellType, ExprType(..)- , ExprTypes(..), queryFields) where+ , ExprTypes(..), queryFields) where import Data.Dynamic import System.Time+import Data.Time.LocalTime -import Database.HaskellDB.BoundedString import Database.HaskellDB.HDBRec (RecCons(..), Record, RecNil(..), ShowLabels)+import Database.HaskellDB.BoundedString import Database.HaskellDB.BoundedList (listBound, Size) import Database.HaskellDB.Query (Expr, Rel, runQueryRel, Query, labels) @@ -36,6 +39,7 @@ | DoubleT | BoolT | CalendarTimeT+ | LocalTimeT | BStrT Int deriving (Eq,Ord,Show,Read) @@ -62,6 +66,7 @@ toHaskellType DoubleT = "Double" toHaskellType BoolT = "Bool" toHaskellType CalendarTimeT = "CalendarTime"+toHaskellType LocalTimeT = "LocalTime" toHaskellType (BStrT a) = "BStr" ++ show a -- | Given a query, returns a list of the field names and their@@ -75,11 +80,7 @@ unRel :: (Rel r) -> r unRel r = undefined -- Only used to get to type-level information. -instance Typeable CalendarTime where -- not available in standard libraries- typeOf _ = mkTyConApp (mkTyCon "System.Time.CalendarTime") []--instance Typeable (BoundedString n) where- typeOf _ = mkTyConApp (mkTyCon "Database.HaskellDB.BoundedString") []+deriving instance Typeable CalendarTime -- not available in standard libraries instance (ExprType a) => ExprType (Maybe a) where fromHaskellType ~(Just e) = ((fst . fromHaskellType $ e), True)@@ -114,9 +115,12 @@ instance ExprType CalendarTime where fromHaskellType _ = (CalendarTimeT, False) +instance ExprType LocalTime where+ fromHaskellType _ = (LocalTimeT, False)+ instance (Size n) => ExprType (BoundedString n) where fromHaskellType b = (BStrT (listBound b), False)- + instance ExprTypes RecNil where fromHaskellTypes _ = []
src/Database/HaskellDB/HDBRec.hs view
@@ -1,3 +1,6 @@+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies+ , TypeSynonymInstances, FlexibleInstances, UndecidableInstances+ , OverlappingInstances #-} ----------------------------------------------------------- -- | -- Module : HDBRec@@ -22,6 +25,7 @@ , FieldTag(..) -- * Record predicates and operations , HasField, Select(..), SetField, setField+ , RecCat(..) -- * Showing and reading records , ShowLabels(..), ShowRecRow(..), ReadRecRow(..) ) where@@ -58,7 +62,6 @@ -> (b -> RecCons f a c) -- ^ New record f # r = let RecCons x _ = f RecNil in RecCons x . r - -- | The empty record emptyRecord :: Record RecNil emptyRecord = id@@ -81,16 +84,16 @@ class RecCat r1 r2 r3 | r1 r2 -> r3 where -- | Concatenates two records.- cat :: r1 -> r2 -> r3+ recCat :: r1 -> r2 -> r3 instance RecCat RecNil r r where- cat RecNil r = r+ recCat ~RecNil r = r instance RecCat r1 r2 r3 => RecCat (RecCons f a r1) r2 (RecCons f a r3) where- cat ~(RecCons x r1) r2 = RecCons x (cat r1 r2)+ recCat ~(RecCons x r1) r2 = RecCons x (recCat r1 r2) instance RecCat r1 r2 r3 => RecCat (Record r1) (Record r2) (Record r3) where- cat r1 r2 = \n -> cat (r1 n) (r2 n)+ recCat r1 r2 = \n -> recCat (r1 n) (r2 n) -- * Field selection
src/Database/HaskellDB/Optimize.hs view
@@ -18,7 +18,7 @@ module Database.HaskellDB.Optimize (optimize, optimizeCriteria) where import Control.Exception (assert)-import Data.List (intersect,(\\),union)+import Data.List (intersect, (\\), union, nub) import Database.HaskellDB.PrimQuery -- | Optimize a PrimQuery@@ -82,36 +82,7 @@ -- or that will be put in a GROUP BY clause. -- These are the associations that will be kept. newAssoc :: Assoc- newAssoc | hasAggregate = groupAssoc ++ liveAssoc- | otherwise = liveAssoc- where- -- when an aggregate expression is in the- -- association we check- -- if an attribute is explicitly added by the user- -- and not already live- -- (ie. "extend" is called), if so we should- -- keep it live to be added in a GROUP BY- -- clause.- groupAssoc = filter (not.isLive)- $ filter newAttr assoc- -- Does the association define a new attribute?- -- (i.e. not just pass on an existing one- -- from the nested query)- newAttr :: (Attribute,PrimExpr) -> Bool- newAttr (attr,AttrExpr name) = (attr /= name)- newAttr _ = True-- -- Is any live attribute bound to an aggregate expression?- hasAggregate :: Bool- hasAggregate = any (isAggregate.snd) liveAssoc-- -- All associations that define live attributes.- liveAssoc :: Assoc- liveAssoc = filter isLive assoc-- -- Is the attribute defined by the association live?- isLive :: (Attribute,PrimExpr) -> Bool- isLive (attr,expr) = attr `elem` live+ newAssoc = filter (isLive live) assoc removeD live (Restrict x query) = Restrict x (removeD (live ++ attrInExpr x) query)@@ -119,18 +90,23 @@ removeD live (Special (Order xs) query) = Special (Order xs) (removeD (live ++ attrInOrder xs) query) --- Filter dead columns from group expression, as they are not used. Note--- live columns are NOT just those that are in the select, but also those--- used in restrictions.-removeD live (Group cols query)- = Group cols (removeD live query)+removeD live (Group cols query) = Group newAssoc (removeD newLive query) where- liveCols = filter ((`elem` live) . fst) cols- -removeD live query- = query+ newLive :: Scheme+ newLive = concat (map (attrInExpr . snd) newAssoc)+ newAssoc :: Assoc+ newAssoc = filter (isLive live) cols +removeD live query = query +-- | Determines if the given column (attribute/expression pair)+-- exists in the scheme given.+isLive :: Scheme -> (Attribute,PrimExpr) -> Bool+isLive live (attr,expr) = attr `elem` live++schemeOf :: (PrimExpr -> Bool) -> Assoc -> Scheme+schemeOf f = map fst . filter (f . snd)+ -- | Remove unused parts of the query removeEmpty :: PrimQuery -> PrimQuery removeEmpty @@ -161,40 +137,62 @@ -- | Collapse adjacent projections mergeProject :: PrimQuery -> PrimQuery mergeProject q- = foldPrimQuery (Empty,BaseTable,project,Restrict,Binary,Group, Special) q+ = foldPrimQuery (Empty, BaseTable, project, Restrict, Binary, Group, Special) q where project assoc1 (Project assoc2 query)- | safe newAssoc = Project newAssoc query+ | equal assoc1 assoc2 = Project assoc2 query+ | safe assoc1 query = Project (subst assoc1 assoc2) query where- newAssoc = subst assoc1 assoc2 - -- "hmm, is this always true ?" (Daan Leijen)- -- "no, not true when assoc uses fields defined in only- -- one of assoc1 or assoc2, which happens- -- when op == Times" (Bjorn Bringert) project assoc query@(Binary Times _ _) = Project assoc query project assoc (Binary op (Project assoc1 query1) (Project assoc2 query2))- | safe newAssoc1 && safe newAssoc2+ | safe assoc1 query1 && safe assoc2 query2 = Binary op (Project newAssoc1 query1) (Project newAssoc2 query2) where newAssoc1 = subst assoc assoc1 newAssoc2 = subst assoc assoc2-+ project assoc query = Project assoc query + -- Replace columns in a1 with+ -- expressions from a2. subst :: Assoc -- ^ Association that we want to change -> Assoc -- ^ Association containing the substitutions -> Assoc subst a1 a2 = map (\(attr,expr) -> (attr, substAttr a2 expr)) a1 - safe :: Assoc -> Bool- safe assoc- = not (any (isAggregate.snd) assoc) || all (isAggregate . snd) assoc+ -- It is safe to merge two projections in two cases. + -- 1. All columns in the outer projections are attributes, with no+ -- computation. This means they merely copy values from the inner+ -- projection to the outer and can be eliminated.+ -- 2. The inner projection does not group on any columns.+ safe :: Assoc -- ^ Outer projection's columns.+ -> PrimQuery -- ^ Inner projection's query.+ -> Bool+ safe outer innerQuery = all isAttr outer || null (groups innerQuery)+ where+ isAttr (_, AttrExpr _) = True+ isAttr _ = False+ + -- Are two associations equal?+ equal :: Assoc -> Assoc -> Bool+ equal assoc1 assoc2 = length assoc1 == length assoc2 &&+ (all (\((a1, _),(a2, _)) -> a1 == a2) $ zip assoc1 assoc2)+ -- Returns grouped columns for a projection. + groups :: PrimQuery -> Scheme+ groups = foldPrimQuery ([], \ _ _ -> [],+ \ _ _ -> [], restrict, + \ _ _ _ -> [], group, special)+ where+ restrict _ rest = rest+ group cols _ = map fst cols+ special _ rest = rest + -- | Push restrictions down through projections and binary ops. pushRestrict :: PrimQuery -> PrimQuery @@ -204,6 +202,9 @@ pushRestrict (Project assoc query) = Project assoc (pushRestrict query) +pushRestrict (Group assoc query)+ = Group assoc (pushRestrict query)+ -- restricts pushRestrict (Restrict x (Project assoc query))@@ -213,7 +214,14 @@ -- with the expression they are bound to by the project expr = substAttr assoc x -- aggregate expressions are not allowed in restricts- safe = not (isAggregate expr)+ safe = not (isAggregate expr) && not (hasAggregates query)+ hasAggregates (Project _ _) = False+ hasAggregates (BaseTable _ _) = False+ hasAggregates (Restrict _ qry) = hasAggregates qry+ hasAggregates (Group _ _) = True+ hasAggregates (Binary _ left right) = hasAggregates left || hasAggregates right+ hasAggregates (Special _ qry) = hasAggregates qry+ hasAggregates Empty = False pushRestrict (Restrict x (Binary op query1 query2)) | noneIn1 = Binary op query1 (pushRestrict (Restrict x query2))@@ -248,11 +256,16 @@ xs' = [OrderExpr o (substAttr assoc e) | OrderExpr o e <- xs] safe = and [not (isAggregate e) | OrderExpr _ e <- xs'] --- Top is pushed through Project if there are no aggregates in the project--- Aggregates can change the number of results.-pushRestrict (Special top@(Top _) (Project assoc query))- | not (any isAggregate (map snd assoc)) - = Project assoc (pushRestrict (Special top query))+-- Top and Offset are pushed through Project if there are no+-- aggregates in the project Aggregates can change the number of+-- results.+pushRestrict (Special op (Project assoc query))+ | topOrOffset op && not (any isAggregate (map snd assoc))+ = Project assoc (pushRestrict (Special op query))+ where+ topOrOffset Top{} = True+ topOrOffset Offset{} = True+ topOrOffset _ = False pushRestrict (Special op (query@(Special _ _))) = case (pushed) of
src/Database/HaskellDB/PrimQuery.hs view
@@ -65,6 +65,7 @@ data RelOp = Times | Union+ | UnionAll | Intersect | Divide | Difference@@ -72,6 +73,7 @@ data SpecialOp = Order [OrderExpr] | Top Int+ | Offset Int deriving (Show) data OrderExpr = OrderExpr OrderOp PrimExpr @@ -89,7 +91,7 @@ | ListExpr [PrimExpr] | ParamExpr (Maybe Name) PrimExpr | FunExpr Name [PrimExpr]- | CastExpr Name PrimExpr-- ^ Cast an expression to a given type.+ | CastExpr Name PrimExpr -- ^ Cast an expression to a given type. deriving (Read,Show) data Literal = NullLit@@ -152,6 +154,7 @@ attributes (Binary op q1 q2) = case op of Times -> attr1 `union` attr2 Union -> attr1+ UnionAll -> attr1 Intersect -> attr1 Divide -> attr1 Difference -> attr1@@ -199,14 +202,17 @@ -- | Determines if a primitive expression represents a constant -- or is an expression only involving constants. isConstant :: PrimExpr -> Bool-isConstant x = countConstant x > 0+isConstant x = countAttr x == 0 where- countConstant = foldPrimExpr (const 0, const 1, binary, unary, aggr, const2 0, const 0,const2 0, const2 0, cast)+ countAttr = foldPrimExpr (const 1, const 0, binary, unary, aggr, _case, list, + const2 1, const2 1, cast) where+ _case cs el = sum (map (uncurry (+)) cs) + el+ list = sum const2 a _ _ = a- binary op x y = if x == 0 || y == 0 then 0 else 1- unary op x = x- aggr op x = x+ binary _ x y = x + y+ unary _ x = x+ aggr _ x = x cast _ n = n isAggregate :: PrimExpr -> Bool
src/Database/HaskellDB/PrintQuery.hs view
@@ -1,131 +1,145 @@------------------------------------------------------------ --- | --- Module : PrintQuery.hs --- Copyright : haskelldb-users@lists.sourceforge.net --- License : BSD-style --- --- Maintainer : haskelldb-users@lists.sourceforge.net --- Stability : experimental --- Portability : non portable --- Author : Justin Bailey (jgbailey AT gmail DOT com) --- Pretty printing for Query, PrimQuery, and SqlSelect values. --- Useful for debugging the library. --- ------------------------------------------------------------ -module Database.HaskellDB.PrintQuery (ppQuery, ppQueryUnOpt - , ppSelect, ppSelectUnOpt, ppSqlSelect, ppPrim) - -where - -import Database.HaskellDB.PrimQuery -import Database.HaskellDB.Sql -import Database.HaskellDB.Query (Query, runQuery, Rel) -import Database.HaskellDB.Optimize (optimize) -import Database.HaskellDB.Sql.Generate (sqlQuery) -import Database.HaskellDB.Sql.Default (defaultSqlGenerator) -import Text.PrettyPrint.HughesPJ - --- | Take a query, turn it into a SqlS -ppSelect :: Query (Rel r) -> Doc -ppSelect qry = ppPQ (sqlQuery defaultSqlGenerator) optimize (runQuery $ qry) - --- | Take a query, turn it into a SqlS -ppSelectUnOpt :: Query (Rel r) -> Doc -ppSelectUnOpt qry = ppPQ (sqlQuery defaultSqlGenerator) id (runQuery $ qry) - --- | Optimize the query and pretty print it. -ppQuery :: Query (Rel r) -> Doc -ppQuery qry = ppPrimF optimize (runQuery $ qry) - --- | Pretty print an unoptimized query. -ppQueryUnOpt :: Query (Rel r) -> Doc -ppQueryUnOpt qry = ppPrimF id (runQuery $ qry) - --- | Pretty print a PrimQuery value. -ppPrim :: PrimQuery -> Doc -ppPrim = ppPrimF id - --- | Transform a PrimQuery according to the function given, then --- pretty print it. -ppPrimF :: (PrimQuery -> PrimQuery) -- ^ Transformation function to apply to PrimQuery first. - -> PrimQuery -- ^ PrimQuery to print. - -> Doc -ppPrimF f qry = ppPrimF' (f qry) - where - ppPrimF' (BaseTable tableName scheme) = - hang (text "BaseTable" <> colon <+> text tableName) - nesting - (brackets (fsep $ punctuate comma (map text scheme))) - ppPrimF' (Project assoc primQuery) = - hang (text "Project") - nesting (brackets (ppAssoc assoc) $+$ - parens (ppPrimF' primQuery)) - ppPrimF' (Restrict primExpr primQuery) = - hang (text "Restrict") - nesting - (ppExpr primExpr $+$ ppPrimF' primQuery) - ppPrimF' (Group assoc primQuery) = - hang (text "Group") - nesting - (brackets (ppAssoc assoc) $+$ - parens (ppPrimF' primQuery)) - ppPrimF' (Binary relOp primQueryL primQueryR) = - hang (text "Binary:" <+> text (show relOp)) - nesting - (parens (ppPrimF' primQueryL) $+$ - parens (ppPrimF' primQueryR)) - ppPrimF' (Special specialOp primQuery) = - hang (text "Special:" <+> text (show specialOp)) - nesting - (parens (ppPrimF' primQuery)) - ppPrimF' Empty = text "Empty" - - -- | Pretty print an Assoc list (i.e. columns and expression). - ppAssoc :: Assoc -> Doc - ppAssoc assoc = fsep . punctuate comma . map (\(a, e) -> text a <> colon <+> ppExpr e) $ assoc - - -- | Pretty print an PrimExpr value. - ppExpr :: PrimExpr -> Doc - ppExpr = text . show - -ppPQ :: (PrimQuery -> SqlSelect) -- ^ Function to turn primitive query into a SqlSelect. - -> (PrimQuery -> PrimQuery) -- ^ Transformation to apply to query, if any. - -> PrimQuery -- ^ The primitive query to transform and print. - -> Doc -ppPQ select trans prim = ppSqlSelect . select . trans $ prim - -ppSqlSelect :: SqlSelect -> Doc -ppSqlSelect (SqlBin string sqlSelectL sqlSelectR) = - hang (text "SqlBin:" <+> text string) nesting - (parens (ppSqlSelect sqlSelectL) $+$ - parens (ppSqlSelect sqlSelectR)) -ppSqlSelect (SqlTable sqlTable) = text "SqlTable:" <+> text sqlTable -ppSqlSelect SqlEmpty = text "SqlEmpty" -ppSqlSelect (SqlSelect options attrs tables criteria groupby orderby extra) = - hang (text "SqlSelect") nesting $ - hang (text "attrs:") nesting (brackets . fsep . punctuate comma . map ppAttr $ attrs) $+$ - text "criteria:" <+> (brackets . fsep . punctuate comma . map ppSqlExpr $ criteria) $+$ - hang (text "tables:") nesting (brackets . fsep . punctuate comma . map ppTable $ tables) $+$ - hang (text "groupby:") nesting (brackets . fsep . punctuate comma . map ppAttr $ groupby) $+$ - hang (text "orderby:") nesting (brackets . fsep . punctuate comma . map ppOrder $ orderby) $+$ - text "extras:" <+> (brackets . fsep. punctuate comma . map text $ extra) $+$ - text "options:" <+> (brackets . fsep . punctuate comma . map text $ options) - -ppTable :: (SqlTable, SqlSelect) -> Doc -ppTable (tbl, select) = - if null tbl - then ppSqlSelect select - else hang (text tbl <> colon) nesting (ppSqlSelect select) - -ppAttr :: (SqlColumn, SqlExpr) -> Doc -ppAttr (col, expr) = text col <> colon <+> ppSqlExpr expr - -ppOrder :: (SqlExpr, SqlOrder) -> Doc -ppOrder (expr, order) = parens (ppSqlExpr expr) <+> text (show order) - -ppSqlExpr :: SqlExpr -> Doc -ppSqlExpr sql = text $ show sql - --- | Nesting level. -nesting :: Int +-----------------------------------------------------------+-- |+-- Module : PrintQuery.hs+-- Copyright : haskelldb-users@lists.sourceforge.net+-- License : BSD-style+-- +-- Maintainer : haskelldb-users@lists.sourceforge.net+-- Stability : experimental+-- Portability : non portable+-- Author : Justin Bailey (jgbailey AT gmail DOT com)+-- Pretty printing for Query, PrimQuery, and SqlSelect values.+-- Useful for debugging the library.+-- +-----------------------------------------------------------+module Database.HaskellDB.PrintQuery + (ppQuery, ppQueryUnOpt+ , ppSelect, ppSelectUnOpt, ppSqlSelect, ppPrim+ , Database.HaskellDB.PrintQuery.ppSql, Database.HaskellDB.PrintQuery.ppSqlUnOpt)++where++import Database.HaskellDB.PrimQuery+import Database.HaskellDB.Sql+import Database.HaskellDB.Query (Query, runQuery, Rel)+import Database.HaskellDB.Optimize (optimize)+import Database.HaskellDB.Sql.Generate (sqlQuery)+import Database.HaskellDB.Sql.Default (defaultSqlGenerator)+import Database.HaskellDB.Sql.Print as Sql (ppSql)+import Text.PrettyPrint.HughesPJ++-- | Take a query, turn it into a SqlSelect and print it.+ppSql :: Query (Rel r) -> Doc+ppSql qry = Sql.ppSql . sqlQuery defaultSqlGenerator . optimize $ runQuery qry++-- | Take a query, turn it into a SqlSelect and print it.+ppSqlUnOpt :: Query (Rel r) -> Doc+ppSqlUnOpt qry = Sql.ppSql . sqlQuery defaultSqlGenerator $ runQuery qry++-- | Take a query, turn it into a SqlSelect and print it.+ppSelect :: Query (Rel r) -> Doc+ppSelect qry = ppPQ (sqlQuery defaultSqlGenerator) optimize (runQuery $ qry)++-- | Take a query, turn it into a SqlSelect and print it, with optimizations.+ppSelectUnOpt :: Query (Rel r) -> Doc+ppSelectUnOpt qry = ppPQ (sqlQuery defaultSqlGenerator) id (runQuery $ qry)++-- | Optimize the query and pretty print the primitive representation.+ppQuery :: Query (Rel r) -> Doc+ppQuery qry = ppPrimF optimize (runQuery $ qry)++-- | Pretty print the primitive representation of an unoptimized query.+ppQueryUnOpt :: Query (Rel r) -> Doc+ppQueryUnOpt qry = ppPrimF id (runQuery $ qry)++-- | Pretty print a PrimQuery value.+ppPrim :: PrimQuery -> Doc+ppPrim = ppPrimF id++-- | Transform a PrimQuery according to the function given, then+-- pretty print it.+ppPrimF :: (PrimQuery -> PrimQuery) -- ^ Transformation function to apply to PrimQuery first.+ -> PrimQuery -- ^ PrimQuery to print.+ -> Doc+ppPrimF f qry = ppPrimF' (f qry)+ where+ ppPrimF' (BaseTable tableName scheme) =+ hang (text "BaseTable" <> colon <+> text tableName)+ nesting+ (brackets (fsep $ punctuate comma (map text scheme)))+ ppPrimF' (Project assoc primQuery) =+ hang (text "Project")+ nesting (brackets (ppAssoc assoc) $+$+ parens (ppPrimF' primQuery)) + ppPrimF' (Restrict primExpr primQuery) =+ hang (text "Restrict")+ nesting+ (ppExpr primExpr $+$ ppPrimF' primQuery)+ ppPrimF' (Group assoc primQuery) =+ hang (text "Group")+ nesting+ (brackets (ppAssoc assoc) $+$+ parens (ppPrimF' primQuery))+ ppPrimF' (Binary relOp primQueryL primQueryR) =+ hang (text "Binary:" <+> text (show relOp))+ nesting+ (parens (ppPrimF' primQueryL) $+$+ parens (ppPrimF' primQueryR))+ ppPrimF' (Special specialOp primQuery) =+ hang (text "Special:" <+> text (show specialOp))+ nesting+ (parens (ppPrimF' primQuery))+ ppPrimF' Empty = text "Empty"++ -- | Pretty print an Assoc list (i.e. columns and expression).+ ppAssoc :: Assoc -> Doc+ ppAssoc assoc = fsep . punctuate comma . map (\(a, e) -> text a <> colon <+> ppExpr e) $ assoc+ + -- | Pretty print an PrimExpr value.+ ppExpr :: PrimExpr -> Doc+ ppExpr = text . show++ppPQ :: (PrimQuery -> SqlSelect) -- ^ Function to turn primitive query into a SqlSelect.+ -> (PrimQuery -> PrimQuery) -- ^ Transformation to apply to query, if any.+ -> PrimQuery -- ^ The primitive query to transform and print.+ -> Doc+ppPQ select trans prim = ppSqlSelect . select . trans $ prim++ppSqlSelect :: SqlSelect -> Doc+ppSqlSelect (SqlBin string sqlSelectL sqlSelectR) =+ hang (text "SqlBin:" <+> text string) nesting+ (parens (ppSqlSelect sqlSelectL) $+$+ parens (ppSqlSelect sqlSelectR))+ppSqlSelect (SqlTable sqlTable) = text "SqlTable:" <+> text sqlTable+ppSqlSelect SqlEmpty = text "SqlEmpty"+ppSqlSelect (SqlSelect options attrs tables criteria groupby orderby extra) =+ hang (text "SqlSelect") nesting $+ hang (text "attrs:") nesting (brackets . fsep . punctuate comma . map ppAttr $ attrs) $+$+ text "criteria:" <+> (brackets . fsep . punctuate comma . map ppSqlExpr $ criteria) $+$+ hang (text "tables:") nesting (brackets . fsep . punctuate comma . map ppTable $ tables) $+$+ maybe (text "groupby: empty") ppGroupBy groupby $+$+ hang (text "orderby:") nesting (brackets . fsep . punctuate comma . map ppOrder $ orderby) $+$+ text "extras:" <+> (brackets . fsep. punctuate comma . map text $ extra) $+$+ text "options:" <+> (brackets . fsep . punctuate comma . map text $ options)++ppGroupBy All = text "groupby: all"+ppGroupBy (Columns cs) = hang (text "groupby:") nesting (brackets . fsep . punctuate comma . map ppAttr $ cs)++ppTable :: (SqlTable, SqlSelect) -> Doc+ppTable (tbl, select) =+ if null tbl+ then ppSqlSelect select+ else hang (text tbl <> colon) nesting (ppSqlSelect select)++ppAttr :: (SqlColumn, SqlExpr) -> Doc+ppAttr (col, expr) = text col <> colon <+> ppSqlExpr expr++ppOrder :: (SqlExpr, SqlOrder) -> Doc+ppOrder (expr, order) = parens (ppSqlExpr expr) <+> text (show order)++ppSqlExpr :: SqlExpr -> Doc+ppSqlExpr sql = text $ show sql++-- | Nesting level.+nesting :: Int nesting = 2
src/Database/HaskellDB/Query.hs view
@@ -1,3 +1,6 @@+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances+ , FlexibleContexts, UndecidableInstances+ , TypeSynonymInstances #-} ----------------------------------------------------------- -- | -- Module : Query@@ -17,52 +20,49 @@ ----------------------------------------------------------- module Database.HaskellDB.Query ( -- * Data and class declarations- Rel(..), Attr(..), Table(..), Query, Expr(..), ExprAggr, OrderExpr- , ToPrimExprs, ShowConstant- , ExprC, ProjectExpr, ProjectRec, InsertRec- , ConstantRecord(..)+ Rel(..), Attr(..), Table(..), Query, Expr(..), OrderExpr+ , ToPrimExprs, ConstantRecord+ , ShowConstant(..), ExprC(..), ProjectExpr, ProjectRec, InsertRec+ , ExprAggr(..), ExprDefault(..)+ , copy, copyAll, RelToRec -- * Operators , (.==.) , (.<>.), (.<.), (.<=.), (.>.), (.>=.) , (.&&.) , (.||.)- , (.*.) , (./.), (.%.), (.+.), (.-.), (.++.)+ , (.*.), (./.), (.+.), (.-.), (.%.), (.++.) , (<<), (<<-)- , recAttr -- * Function declarations , project, restrict, table, unique- , union, intersect, divide, minus+ , union, unionAll, intersect, divide, minus , _not, like, _in, cat, _length , isNull, notNull- , fromNull- , constant, constJust- , param, namedParam, Args, func, constNull, cast- , toStr, coerce- , select- , count, _sum, _max, _min, avg- , literal+ , fromNull, fromVal+ , constant, constVal, constNull, constExpr+ , param, namedParam, Args, func, cast+ , toStr, coerce , select+ , count, _sum, _max, _min, avg , literal , stddev, stddevP, variance, varianceP- , asc, desc, order- , top --, topPercent- , _case- , _default- -- * Internals- , runQuery, runQueryRel- , subQuery- , attribute, tableName, baseTable- , attributeName, exprs, labels+ , asc, desc, order , top, offset+ , _case , _default+ -- * Internals+ , runQuery, runQueryRel, unQuery+ , subQuery+ , attribute, attributeName, tableName, baseTable, emptyTable+ , exprs, labels, tableRec + , constantRecord ) where--import Database.HaskellDB.HDBRec+import Database.HaskellDB.HDBRec import Database.HaskellDB.PrimQuery import Database.HaskellDB.BoundedString import Database.HaskellDB.BoundedList +import Control.Applicative+import Control.Monad import System.Time (CalendarTime) ----------------------------------------------------------- -- Operators ----------------------------------------------------------- ---infix 9 ! infix 8 `like`, `_in` infixl 7 .*., ./., .%. infixl 6 .+.,.-.@@ -82,14 +82,14 @@ data Rel r = Rel Alias Scheme -- | Type of normal expressions, contains the untyped PrimExpr.-data Expr a = Expr PrimExpr+newtype Expr a = Expr PrimExpr deriving (Read, Show) -- | Type of aggregate expressions.-data ExprAggr a = ExprAggr PrimExpr deriving (Read, Show)+newtype ExprAggr a = ExprAggr PrimExpr deriving (Read, Show) -- | The type of default expressions.-data ExprDefault a = ExprDefault PrimExpr deriving (Read, Show)+newtype ExprDefault a = ExprDefault PrimExpr deriving (Read, Show) -- | Basic tables, contains table name and an -- association from attributes to attribute@@ -137,7 +137,7 @@ class InsertRec r er | r -> er instance InsertRec RecNil RecNil instance (InsertExpr e, InsertRec r er) => - InsertRec (RecCons f (e a) r) (RecCons f (Expr a) er)+ InsertRec (RecCons f (e a) r) (RecCons f (Expr a) er) -- | Class of expressions that can be used with 'project'. class ExprC e => ProjectExpr e@@ -150,7 +150,7 @@ class ProjectRec r er | r -> er instance ProjectRec RecNil RecNil instance (ProjectExpr e, ProjectRec r er) => - ProjectRec (RecCons f (e a) r) (RecCons f (Expr a) er)+ ProjectRec (RecCons f (e a) r) (RecCons f (Expr a) er) ----------------------------------------------------------- -- Record operators@@ -166,25 +166,56 @@ -- | Convenience operator for constructing records of constants. -- Useful primarily with 'insert'. -- @f <<- x@ is the same as @f << constant x@-( <<- ) :: ShowConstant a => - Attr f a -- ^ Field label- -> a -- ^ Field value- -> Record (RecCons f (Expr a) RecNil) -- ^ New record+( <<- ) :: ShowConstant a =>+ Attr f a -- ^ Field label+ -> a -- ^ Field value+ -> Record (RecCons f (Expr a) RecNil) -- ^ New record f <<- x = f << constant x -- | Creates a single-field record from an attribute and a table. Useful--- for building projections that will re-use the same attribute name. @recAttr attr tbl@ is+-- for building projections that will re-use the same attribute name. @copy attr tbl@ is -- equivalent to: ----- @attr << tbl ! attr@+-- @attr .=. (tbl .!. attr)@ ---recAttr :: (HasField f r) => Attr f a -> Rel r -> Record (RecCons f (Expr a) RecNil)-recAttr attr tbl = attr << tbl ! attr+copy :: (HasField f r) => Attr f a -> Rel r -> Record (RecCons f (Expr a) RecNil)+copy attr tbl = attr << tbl ! attr --------------------------------------------------------------- Basic relational operators------------------------------------------------------------+-- | Copies all columns in the relation given. Useful for appending+-- the remaining columns in a table to a projection. For example:+--+-- > query = do+-- > tbl <- table some_table+-- > project $ copyAll tbl+--+-- will add all columns in "some_table" to the query.+copyAll :: (RelToRec r) => Rel r -> Record r+copyAll = relToRec +-- | Helper class which gives a polymorphic+-- copy function that can turn a Rel into a Record.+class RelToRec a where+ relToRec :: Rel a -> Record a++instance RelToRec RecNil where+ relToRec v = \_ -> unRel v+ where + unRel :: Rel r -> r+ unRel = error "unRel RelToRec RecNil"++-- All this type magic takes the first field off the Rel (Record ...) type, +-- turns it into a (Record ...) type, and prepends it to the rest of the +-- converted record. +instance (RelToRec rest, FieldTag f) => RelToRec (RecCons f (Expr a) rest) where+ relToRec t@(Rel v s) = copy (attr . fieldT $ t) t # relToRec (restT t) + where+ attr :: FieldTag f => f -> Attr f a+ attr = Attr . fieldName+ fieldT :: Rel (RecCons f a rest) -> f + fieldT = error "fieldT"+ restT :: Rel (RecCons f a rest) -> Rel rest+ restT _ = Rel v s+ -- | Field selection operator. It is overloaded to work for both -- relations in a query and the result of a query. -- That is, it corresponds to both '!' and '!.' from the original@@ -198,6 +229,10 @@ select (Attr attribute) (Rel alias scheme) = Expr (AttrExpr (fresh alias attribute)) +-----------------------------------------------------------+-- Basic relational operators+-----------------------------------------------------------+ -- | Specifies a subset of the columns in the table. project :: (ShowLabels r, ToPrimExprs r, ProjectRec r er) => Record r -> Query (Rel er) project r@@ -208,7 +243,6 @@ updatePrimQuery (extend assoc) return (Rel alias scheme) - -- | Restricts the records to only those who evaluates the -- expression to True. restrict :: Expr Bool -> Query ()@@ -271,6 +305,10 @@ union :: Query (Rel r) -> Query (Rel r) -> Query (Rel r) union = binrel Union +-- | UNION ALL+unionAll :: Query (Rel r) -> Query (Rel r) -> Query (Rel r)+unionAll = binrel UnionAll+ -- | Return all records which are present in both relations. intersect :: Query (Rel r) -> Query (Rel r) -> Query (Rel r) intersect = binrel Intersect@@ -303,11 +341,20 @@ tableName :: Table t -> TableName tableName (Table n _) = n --- used in table definitions+-- Type-level function to return the type of a table's row.+tableRec :: Table (Record r) -> Record r+tableRec = error "tableRec should never be evaluated." +-- used in table definitions baseTable :: (ShowLabels r, ToPrimExprs r) => TableName -> Record r -> Table r baseTable t r = Table t (zip (labels r) (exprs r)) +-- | For queries against fake tables, such as+-- 'information_schema.information_schema_catalog_name'. Useful for+-- constructing queries that contain constant data (and do not select+-- from columns) but need a table to select from.+emptyTable :: TableName -> Table (Record RecNil)+emptyTable t = Table t [] attribute :: String -> Expr a attribute name = Expr (AttrExpr name)@@ -334,35 +381,23 @@ binop op (Expr primExpr1) (Expr primExpr2) = Expr (BinExpr op primExpr1 primExpr2) --- | (.==.) is used in a similar way as the standard op (==) in--- Haskell and = in SQL, but takes two 'Expr' as arguments and --- returns an 'Expr' Bool.+-- | Equality comparison on Exprs, = in SQL. (.==.) :: Eq a => Expr a -> Expr a -> Expr Bool (.==.) = binop OpEq --- | (.\<>.) is used in a similar way as the standard op (\/=) in--- Haskell and \<> in SQL, but takes two 'Expr' as arguments and --- returns an 'Expr' Bool.+-- | Inequality on Exprs, <> in SQL. (.<>.) :: Eq a => Expr a -> Expr a -> Expr Bool (.<>.) = binop OpNotEq --- | As with (.==.) and (.\<>.), this op has a standard Haskell--- op counterpart; (\<) and an SQL counterpart; \< (.<.) :: Ord a => Expr a -> Expr a -> Expr Bool (.<.) = binop OpLt --- | As with (.==.) and (.\<>.), this op have a standard Haskell--- op counterpart, (\<=) and an SQL counterpart; <=. (.<=.) :: Ord a => Expr a -> Expr a -> Expr Bool (.<=.) = binop OpLtEq --- | As with (.==.) and (.\<>.), this op have a standard Haskell--- op counterpart, (>) and an SQL counterpart; >. (.>.) :: Ord a => Expr a -> Expr a -> Expr Bool (.>.) = binop OpGt --- | As with (.==.) and (.\<>.), this op have a standard Haskell--- op counterpart, (>=) and an SQL counterpart; >=. (.>=.) :: Ord a => Expr a -> Expr a -> Expr Bool (.>=.) = binop OpGtEq @@ -370,13 +405,11 @@ _not :: Expr Bool -> Expr Bool _not = unop OpNot --- | \"Logical and\" on 'Expr', similar to the (&&) op in--- Haskell and AND in SQL.+-- | \"Logical and\" on 'Expr', AND in SQL. (.&&.):: Expr Bool -> Expr Bool -> Expr Bool (.&&.) = binop OpAnd --- | \"Logical or\" on 'Expr', similar to the (||) op in--- Haskell and OR in SQL.+-- | \"Logical or\" on 'Expr'. OR in SQL. (.||.) :: Expr Bool -> Expr Bool -> Expr Bool (.||.) = binop OpOr @@ -454,14 +487,6 @@ -> Expr a _case cs (Expr el) = Expr (CaseExpr [ (c,e) | (Expr c, Expr e) <- cs] el) --- | Takes a default value a and a nullable value. If the value is NULL,--- the default value is returned, otherwise the value itself is returned.--- Simliar to 'fromMaybe'-fromNull :: Expr a -- ^ Default value (to be returned for 'Nothing')- -> Expr (Maybe a) -- ^ A nullable expression- -> Expr a-fromNull d x@(Expr px) = _case [(isNull x, d)] (Expr px)- -- | Class which can convert BoundedStrings to normal strings, -- even inside type constructors. Useful when a field -- is defined as a BoundedString (e.g. "Expr BStr10" or "Expr (Maybe BStr20)") but@@ -492,12 +517,17 @@ toStr :: s -> d instance (Size n) => BStrToStr (Expr (BoundedString n)) (Expr String) where- toStr (Expr e) = Expr e+ toStr (Expr e) = (Expr e) instance (Size n) => BStrToStr (Expr (Maybe (BoundedString n))) (Expr (Maybe String)) where- toStr (Expr m) = Expr m+ toStr (Expr m) = (Expr m) +instance BStrToStr (Expr (Maybe String)) (Expr (Maybe String)) where+ toStr (Expr m) = (Expr m) +instance BStrToStr (Expr String) (Expr String) where+ toStr (Expr m) = (Expr m)+ ----------------------------------------------------------- -- Using arbitrary SQL functions in a type-safe way. -----------------------------------------------------------@@ -591,6 +621,7 @@ instance Size n => ShowConstant (BoundedString n) where showConstant = showConstant . fromBounded+ -- | Creates a constant expression from a haskell value. constant :: ShowConstant a => a -> Expr a constant x = Expr (ConstExpr (showConstant x))@@ -599,11 +630,31 @@ literal :: String -> Expr a literal x = Expr (ConstExpr (OtherLit x)) +-- | Takes a default value a and a nullable value. If the value is NULL,+-- the default value is returned, otherwise the value itself is returned.+-- Simliar to 'fromMaybe'+fromNull :: Expr a -- ^ Default value (to be returned for 'Nothing')+ -> Expr (Maybe a) -- ^ A nullable expression+ -> Expr a+fromNull d x@(Expr px) = _case [(isNull x, d)] (Expr px)++-- | Similar to fromNull, but takes a +-- value argument rather than an Expr.+fromVal :: ShowConstant a => a + -> Expr (Maybe a)+ -> Expr a+fromVal = fromNull . constant + -- | Turn constant data into a nullable expression. -- Same as @constant . Just@-constJust :: ShowConstant a => a -> Expr (Maybe a)-constJust x = constant (Just x)+constExpr :: Expr a -> Expr (Maybe a)+constExpr (Expr x) = (Expr x) +-- | Turn constant data into a nullable expression. +-- Same as @constant . Just@+constVal :: ShowConstant a => a -> Expr (Maybe a)+constVal x = constant (Just x)+ -- | Represents a null value. constNull :: Expr (Maybe a) constNull = Expr (ConstExpr NullLit)@@ -623,6 +674,8 @@ -> Expr b -- ^ Destination type. coerce (Expr e) = Expr e +-- | Converts records w/o Expr (usually from database+-- queries) to records with Expr types. class ConstantRecord r cr | r -> cr where constantRecord :: r -> cr @@ -632,46 +685,14 @@ instance ConstantRecord RecNil RecNil where constantRecord RecNil = RecNil -instance (ShowConstant a, ConstantRecord r cr) +instance (ShowConstant a, ConstantRecord r cr) => ConstantRecord (RecCons f a r) (RecCons f (Expr a) cr) where constantRecord ~(RecCons x rs) = RecCons (constant x) (constantRecord rs) ----------------------------------------------------------- -- Aggregate operators------ I have changed these to take an expression instead of--- a relation and an attribute, since that seemed --- unneccessarily restrictive. I have probably overlooked --- something in doing so, so I left the old code commented out.--- Bjorn Bringert, 2004-01-10 ----------------------------------------------------------- -{--aggregate :: HasField f r => AggrOp -> Rel r -> Attr f a -> Expr b-aggregate op rel attr- = Expr (AggrExpr op primExpr)- where- (Expr primExpr) = rel ! attr--count :: HasField f r => Rel r -> Attr f a -> Expr Int-count x = aggregate AggrCount x---numAggregate :: (Num a,HasField f r) => AggrOp -> Rel r -> Attr f a -> Expr a-numAggregate = aggregate--_sum,_max,_min,avg,stddev,stddevP,variance,varianceP - :: (Num a,HasField f r) => Rel r -> Attr f a -> Expr a-_sum x = numAggregate AggrSum x-_max x = numAggregate AggrMax x-_min x = numAggregate AggrMin x-avg x = numAggregate AggrAvg x-stddev x = numAggregate AggrStdDev x-stddevP x = numAggregate AggrStdDevP x-variance x = numAggregate AggrVar x-varianceP x = numAggregate AggrVarP x--}- aggregate :: AggrOp -> Expr a -> ExprAggr b aggregate op (Expr primExpr) = ExprAggr (AggrExpr op primExpr) @@ -717,6 +738,10 @@ top :: Int -> Query () top n = updatePrimQuery_ (Special (Top n)) +-- | Skip the n topmost records.+offset :: Int -> Query ()+offset n = updatePrimQuery_ (Special (Offset n))+ ----------------------------------------------------------- -- Ordering results -----------------------------------------------------------@@ -730,14 +755,14 @@ -- Takes a relation and an attribute of that relation, which -- is used for the ordering. asc :: HasField f r => Rel r -> Attr f a -> OrderExpr-asc rel attr = orderOp OpAsc rel attr+asc rel attr = orderOp OpAsc rel attr -- | Use this together with the function 'order' to -- order the results of a query in descending order. -- Takes a relation and an attribute of that relation, which -- is used for the ordering.-desc :: HasField f r => Rel r -> Attr f a -> OrderExpr-desc rel attr = orderOp OpDesc rel attr+desc :: (HasField f r) => Rel r -> Attr f a -> OrderExpr+desc rel attr = orderOp OpDesc rel attr -- | Order the results of a query. -- Use this with the 'asc' or 'desc' functions.@@ -748,6 +773,9 @@ -- Query Monad ----------------------------------------------------------- +unQuery :: Query a -> a+unQuery (Query g) = fst $ g (1, Empty)+ runQuery :: Query (Rel r) -> PrimQuery runQuery = fst . runQueryRel @@ -784,6 +812,10 @@ (Query h) = f x in (h q1)) +instance Applicative Query where+ pure = return+ (<*>) = ap+ updatePrimQuery :: (PrimQuery -> PrimQuery) -> Query PrimQuery updatePrimQuery f = Query (\(i,qt) -> (qt,(i,f qt))) @@ -793,7 +825,6 @@ newAlias :: Query Alias newAlias = Query (\(i,qt) -> (i,(i+1,qt))) - -- fresh 0 is used in the 'Database' module fresh :: Alias -> Attribute -> Attribute fresh 0 attribute = attribute@@ -816,12 +847,3 @@ instance (ExprC e, ToPrimExprs r) => ToPrimExprs (RecCons l (e a) r) where toPrimExprs ~(RecCons e r) = primExpr e : toPrimExprs r -{---exprs :: ShowRecRow r => Record r -> [PrimExpr]-exprs r = map (readPrimExpr . snd) (showRecRow r)- where- readPrimExpr s = case (reads (s "")) of- [(Expr qx,_)] -> qx- _ -> error ("record with invalid expression value: " ++ (s ""))--}
src/Database/HaskellDB/Sql.hs view
@@ -27,8 +27,9 @@ SqlDrop(..), SqlExpr(..),+ Mark(..), - newSelect+ newSelect, foldSqlExpr, foldSqlSelect ) where @@ -51,13 +52,16 @@ | SqlType2 String Int Int deriving Show +data Mark = All | Columns [(SqlColumn, SqlExpr)]+ deriving Show+ -- | Data type for SQL SELECT statements. data SqlSelect = SqlSelect { options :: [String], -- ^ DISTINCT, ALL etc. attrs :: [(SqlColumn,SqlExpr)], -- ^ result tables :: [(SqlTable,SqlSelect)], -- ^ FROM criteria :: [SqlExpr], -- ^ WHERE- groupby :: [(SqlColumn,SqlExpr)], -- ^ GROUP BY+ groupby :: Maybe Mark, -- ^ GROUP BY orderby :: [(SqlExpr,SqlOrder)], -- ^ ORDER BY extra :: [String] -- ^ TOP n, etc. }@@ -65,13 +69,31 @@ | SqlTable SqlTable -- ^ Select a whole table. | SqlEmpty -- ^ Empty select. deriving Show- ++-- | Transform a SqlSelect value.+foldSqlSelect :: ([String] -> [(SqlColumn,SqlExpr)] + -> [(SqlTable, t)] + -> [SqlExpr] -> Maybe Mark + -> [(SqlExpr,SqlOrder)] + -> [String] -> t+ , String -> t -> t -> t+ , SqlTable -> t, t) + -> SqlSelect + -> t+foldSqlSelect (select, bin, table, empty) = fold+ where+ fold (SqlSelect opt attr tab crit grou ord ext) = select opt attr (map (\(t, s) -> (t, fold s)) tab) crit grou ord ext+ fold (SqlBin op left right) = bin op (fold left) (fold right)+ fold (SqlTable tab) = table tab+ fold SqlEmpty = empty+ -- | Expressions in SQL statements. data SqlExpr = ColumnSqlExpr SqlColumn | BinSqlExpr String SqlExpr SqlExpr | PrefixSqlExpr String SqlExpr | PostfixSqlExpr String SqlExpr | FunSqlExpr String [SqlExpr]+ | AggrFunSqlExpr String [SqlExpr] -- ^ Aggregate functions separate from normal functions. | ConstSqlExpr String | CaseSqlExpr [(SqlExpr,SqlExpr)] SqlExpr | ListSqlExpr [SqlExpr]@@ -82,6 +104,41 @@ | CastSqlExpr String SqlExpr deriving Show +-- | Transform a SqlExpr value.+foldSqlExpr :: (SqlColumn -> t -- column+ , String -> t -> t -> t -- bin+ , String -> t -> t -- prefix+ , String -> t -> t -- postfix+ , String -> [t] -> t -- fun+ , String -> [t] -> t -- aggr+ , String -> t -- constant+ , [(t,t)] -> t -> t -- _case+ , [t] -> t -- list+ , SqlSelect -> t -- exists+ , (Maybe SqlName) -> t -> t -- param+ , t -- placeHolder+ , t -> t -- parens+ , String -> t -> t {- casts -}) + -> SqlExpr + -> t+foldSqlExpr (column, bin, prefix, postfix, fun, aggr, constant, _case, list, exists, + param, placeHolder, parens, casts) = fold+ where+ fold (ColumnSqlExpr col) = column col+ fold (BinSqlExpr op left right) = bin op (fold left) (fold right)+ fold (PrefixSqlExpr op exp) = prefix op (fold exp)+ fold (PostfixSqlExpr op exp) = postfix op (fold exp)+ fold (FunSqlExpr name exprs) = fun name (map fold exprs)+ fold (AggrFunSqlExpr name exprs) = aggr name (map fold exprs)+ fold (ConstSqlExpr c) = constant c+ fold (CaseSqlExpr cases def) = _case (map (\(e1, e2) -> (fold e1, fold e2)) cases) (fold def)+ fold (ListSqlExpr exprs) = list (map fold exprs)+ fold (ExistsSqlExpr select) = exists select+ fold (ParamSqlExpr name exp) = param name (fold exp)+ fold PlaceHolderSqlExpr = placeHolder+ fold (ParensSqlExpr exp) = parens (fold exp)+ fold (CastSqlExpr typ exp ) = casts typ (fold exp) + -- | Data type for SQL UPDATE statements. data SqlUpdate = SqlUpdate SqlTable [(SqlColumn,SqlExpr)] [SqlExpr] @@ -106,7 +163,7 @@ attrs = [], tables = [], criteria = [],- groupby = [],+ groupby = Nothing, orderby = [], extra = [] }
src/Database/HaskellDB/Sql/Default.hs view
@@ -53,6 +53,7 @@ import System.Time import Data.Maybe (catMaybes) import Data.List (nubBy)+import qualified Data.Map as Map (fromList, lookup) mkSqlGenerator :: SqlGenerator -> SqlGenerator mkSqlGenerator gen = SqlGenerator @@ -96,7 +97,8 @@ IntegerT -> SqlType "bigint" DoubleT -> SqlType "double precision" BoolT -> SqlType "bit"- CalendarTimeT -> SqlType "timestamp"+ CalendarTimeT -> SqlType "timestamp with time zone"+ LocalTimeT -> SqlType "timestamp without time zone" BStrT a -> SqlType1 "varchar" a -----------------------------------------------------------@@ -122,55 +124,115 @@ defaultSqlProject :: SqlGenerator -> Assoc -> SqlSelect -> SqlSelect defaultSqlProject gen assoc q- | hasAggr = select { groupby = toSqlAssoc gen groupableProjections ++ groupableOrderCols }- | otherwise = select - where- select = sql { attrs = toSqlAssoc gen assoc }- sql = toSqlSelect q- hasAggr = (not . null . filter (isAggregate . snd)) assoc- -- Find projected columns that are not constants or aggregates.- groupableProjections = filter (not . (\x -> isAggregate x || isConstant x) . snd) assoc- -- Get list of order by columns which do not appear in- -- projected non-aggregate columns already, if any.- groupableOrderCols =- let eligible = filter (\x -> case x of- (ColumnSqlExpr attr) ->- not (attr `elem` groupableAttrs)- _ -> False) .- map fst $ orderby sql- -- List of non-aggregated columns which are only attribute expressions, i.e.- -- aliased columns. - groupableAttrs = [col | (AttrExpr col) <- map snd groupableProjections]- in [(s, e) | e@(ColumnSqlExpr s) <- eligible]+ -- This mess ensures we do not create another layer of SELECT when+ -- dealing with GROUP BY phrases. If the select being built is a+ -- real select (not a table or binary operation) and all columns to+ -- be projected are just attributes (i.e., they copy column names+ -- but do no computation), then we do not need to create another+ -- layer of SELECT. We will re-use the existing select.+ | all isAttr assoc && validSelect q = + let groupables = case groupableSqlColumns . attrs $ q of+ [] -> Nothing+ gs -> Just (Columns gs)+ -- Looks at SqlSelect columns and determines if they need to+ -- be grouped. Not the sames as groupableProjects because this+ -- operates on values from a SqlSelect, not PrimQuery.+ groupableSqlColumns :: [(SqlColumn,SqlExpr)] -> [(SqlColumn,SqlExpr)]+ groupableSqlColumns = filter groupable+ where+ id2 _ t = t+ const2 t _ _ = t+ -- determine if a sql expression should be + -- placed in a group by clause. Only columns, non-aggregate+ -- functions and expressions involving either are+ -- groupable. Constants are not groupable. If an expression+ -- contains any groupable values, then whole expression is groupable.+ groupable (col, expr) = foldSqlExpr (const True -- column+ , (\ _ left right -> left || right) -- binary+ , const2 False -- PrefixSqlExpr + , const2 False -- PostfixSqlExpr+ , const2 True -- FunSqlExpr+ , const2 False -- AggrFunSqlExpr+ , const False -- ConstSqlExpr+ , (\cs e -> and (map (uncurry (||)) cs) || e) -- CaseSqlExpr+ , and -- ListSqlExpr+ , const False -- ExistsSqlExpr+ , const2 False -- ParamSqlExpr+ , False -- PlaceHolderSqlExpr+ , id -- ParensSqlExpr+ , id2 {- CastSqlExpr -}) expr+ -- Rename projected columns in + -- a select. Since we did not create another+ -- layer of SELECT, we have to propogate the association list+ -- provided into the current query, or it will not create columns+ -- with the right names. We only go one level - no need to recursively+ -- descend into all queries luckily.+ subst :: Assoc -> SqlSelect -> SqlSelect+ subst outer query@(SqlSelect { attrs = cols+ , criteria = crits+ , groupby = gru+ , orderby = order }) =+ -- map attributes to their aliased columns.+ let colToAliases = Map.fromList [(column, alias) | (alias, AttrExpr column) <- outer] + getAlias column = case Map.lookup column colToAliases of+ Just alias -> alias+ _ -> column+ substExpr = foldSqlExpr (ColumnSqlExpr . getAlias, BinSqlExpr, PrefixSqlExpr, PostfixSqlExpr+ , FunSqlExpr, AggrFunSqlExpr, ConstSqlExpr, CaseSqlExpr+ , ListSqlExpr, ExistsSqlExpr, ParamSqlExpr, PlaceHolderSqlExpr+ , ParensSqlExpr,CastSqlExpr)+ substGroup (Just (Columns cols)) = Just . Columns . map (\(col, expr) -> (getAlias col, expr)) $ cols+ substGroup g = g+ -- replace attributes with alias from outer query + in query { attrs = map (\(currCol, expr) -> (getAlias currCol, expr)) cols+ , criteria = map substExpr crits + , groupby = substGroup gru+ , orderby = map (\(expr, ord) -> (substExpr expr, ord)) order } + in subst assoc (if hasGroupMark q + -- A groupMark indicates the select wants to group+ -- on "all" columns. We replace the mark with the+ -- list of groupable columns. + then q { groupby = groupables }+ -- Otherwise, we just re-use the query without+ -- changing it (modulo substitutions).+ else q)+ | hasAggr assoc || hasGroupMark newSelect = + let g = groupByColumns assoc newSelect+ in if null g+ then newSelect { groupby = Nothing }+ else newSelect { groupby = Just (Columns g) }+ | otherwise = newSelect + where+ newSelect = (toSqlSelect q) { attrs = toSqlAssoc gen assoc }+ hasAggr = not . null . filter (isAggregate . snd) --- | Takes all non-aggregate expressions in the select and adds them to--- the 'group by' clause.-defaultSqlGroup :: SqlGenerator -> Assoc -> SqlSelect -> SqlSelect-defaultSqlGroup gen cols q =- let selectCols = concat (allCols q) -- List of all columns in order by, group by or 'select' clause in SqlSelect.- -- Nested search for all valid columns.- allCols :: SqlSelect -> [[(SqlColumn, SqlExpr)]]- allCols (SqlSelect { attrs = a, groupby = g, tables = t, orderby = o}) = a : g : toColExpr o : concatMap (allCols . snd) t- allCols (SqlBin _ l r) = allCols l ++ allCols r- allCols _ = []- -- Convert order by expressions to SqlColumn looking expressions.- -- Luckily, order by never has antyhig but ColumnSqlExpr in it for now.- toColExpr :: [(SqlExpr,SqlOrder)] -> [(SqlColumn,SqlExpr)]- toColExpr = - let f (ColumnSqlExpr s) = Just (s, undefined)- in catMaybes . map (f . fst)- -- Ensure that each column in the groupby actually exists- -- in the projection. Also converts all expressions- -- to ColumnSqlExpr so they work correctly in group by.- mkValidCol (name, expr) =- case lookup name selectCols of- Just _ -> Just (name, sqlExpr gen expr)- Nothing -> Nothing- select = toSqlSelect q- groupbys = catMaybes . map mkValidCol $ cols- in select { groupby = groupbys }+ isAttr (_, AttrExpr _) = True+ isAttr _ = False + validSelect SqlSelect { attrs = (_:_) } = True+ validSelect _ = False + hasGroupMark (SqlSelect { groupby = Just All }) = True+ hasGroupMark _ = False++ groupByColumns assoc sql = toSqlAssoc gen (groupableProjections assoc) ++ groupableOrderCols sql + -- Find projected columns that are not constants or aggregates.+ groupableProjections assoc = filter (not . (\x -> isAggregate x || isConstant x) . snd) assoc+ -- Get list of order by columns which do not appear in+ -- projected non-aggregate columns already, if any.+ groupableOrderCols sql =+ let eligible = filter (\x -> case x of+ (ColumnSqlExpr attr) -> True+ _ -> False) + in [(s, e) | e@(ColumnSqlExpr s) <- eligible . map fst $ orderby sql]+++-- | Ensures the groupby value on the SqlSelect either preserves existing +-- grouping or that it will group on all columns (i.e, Mark == All).+defaultSqlGroup :: SqlGenerator -> Assoc -> SqlSelect -> SqlSelect+defaultSqlGroup _ _ q@(SqlSelect { groupby = Nothing }) = q { groupby = Just All }+defaultSqlGroup _ _ q = q + defaultSqlRestrict :: SqlGenerator -> PrimExpr -> SqlSelect -> SqlSelect defaultSqlRestrict gen expr q = sql { criteria = sqlExpr gen expr : criteria sql }@@ -178,12 +240,13 @@ sql = toSqlSelect q defaultSqlBinary :: SqlGenerator -> RelOp -> SqlSelect -> SqlSelect -> SqlSelect-defaultSqlBinary _ Times q1 q2 +defaultSqlBinary _ Times q1@(SqlSelect { }) q2@(SqlSelect { }) | null (attrs q1) = addTable q1 q2 | null (attrs q2) = addTable q2 q1 | otherwise = newSelect { tables = [("",q1),("",q2)] } where addTable sql q = sql{ tables = tables sql ++ [("",q)] }+defaultSqlBinary _ Times q1 q2 = newSelect { tables = [("", q1), ("", q2)] } defaultSqlBinary _ op q1 q2 = SqlBin (toSqlOp op) q1 q2 @@ -203,6 +266,9 @@ -- maybe we should use ROW_NUMBER() here = sql { extra = ("LIMIT " ++ show n) : extra sql } where sql = toSqlSelect q+defaultSqlSpecial _ (Offset n) q =+ sql { extra = ("OFFSET " ++ show n) : extra sql }+ where sql = toSqlSelect q toSqlOrder :: SqlGenerator -> OrderExpr -> (SqlExpr,SqlOrder)@@ -212,39 +278,39 @@ OpDesc -> SqlDesc -- | Make sure our SqlSelect statement is really a SqlSelect and not--- one other constructors.+-- another constructor. toSqlSelect :: SqlSelect -> SqlSelect toSqlSelect sql = case sql of- (SqlEmpty) -> newSelect- (SqlTable name) -> newSelect { tables = [("",sql)] }- (SqlBin op q1 q2) -> newSelect { tables = [("",sql)] }- (SqlSelect { groupby = group, attrs = cols, tables = tbls})- | null cols && null group -> sql - | null cols && not (null group) ->- -- This situation arises when a columns used in a group by are- -- not explicitly projected, or only aggregates are.- --- -- We make the groupby its own "subquery" below which projects- -- only "group by" columns, without introducing any aliases. We then- -- create a new select which projects the original columns projected by- -- the group by (i.e. those in the "tables" slot of the groupby select).- --- -- This addresses a bug where GROUP BY statements would disappear- -- if the query did not use the grouped columns, or the would- -- float out of subqueries indirectly.- --- let removeDups = nubBy (\(c1, _) (c2, _) -> c1 == c2)- -- Makes a list of columns pass-through - i.e. projected- -- with no aliasing.- passThrough = map ((\c -> (c, ColumnSqlExpr c)) . fst)- -- List of columns projected by subquery found in tables field.- currProj = passThrough $ concatMap (attrs . snd) tbls- -- Columns projected due the group by- groupProj = passThrough group- newSql = sql { attrs = removeDups $ groupProj ++ currProj }- in newSelect { attrs = currProj- , tables = [("", newSql)]}- | otherwise -> newSelect { tables = [("",sql)] }+ SqlEmpty -> newSelect+ SqlTable name -> newSelect { tables = [("",sql)] }+ -- Below we make sure to bring groupby marks that have not + -- been processed up the tree. The mark moves up the tree+ -- for efficiency. A "Columns" mark does not move -- it indicates+ -- a select that will use a group by. An All mark does move, as it+ -- needs to find its containing projection. Marks that move are+ -- replaced by Nothing.+ SqlBin _ _ _ -> + let (prevGroup, newSql) = findGroup sql+ findGroup (SqlBin op q1 q2) = + let (g1, q1') = findGroup q1+ (g2, q2') = findGroup q2+ in (g1 `or` g2, SqlBin op q1' q2')+ findGroup q@(SqlSelect { groupby = Just (Columns _) }) = (Nothing, q)+ findGroup q@(SqlSelect { groupby = Just All }) = (Just All, q { groupby = Nothing })+ findGroup s = (Nothing, s)+ or l r = maybe r Just l+ in newSelect { tables = [("", newSql)]+ , groupby = prevGroup }+ SqlSelect { attrs = [] } -> sql+ -- Here we have a mark that should not move. + SqlSelect { groupby = Just (Columns _)} ->+ newSelect { tables = [("", sql)] }+ -- Any mark here should be moved. Notice we set the+ -- previous mark with Nothing (though it may already be+ -- Nothing).+ SqlSelect { groupby = group } ->+ newSelect { tables = [("", sql { groupby = Nothing})]+ , groupby = group } toSqlAssoc :: SqlGenerator -> Assoc -> [(SqlColumn,SqlExpr)]@@ -252,6 +318,7 @@ toSqlOp :: RelOp -> String toSqlOp Union = "UNION"+toSqlOp UnionAll = "UNION ALL" toSqlOp Intersect = "INTERSECT" toSqlOp Divide = "DIVIDE" toSqlOp Difference = "EXCEPT"@@ -370,17 +437,23 @@ (paren leftE, rightE) (OpOr, e1, e2@(BinExpr OpAnd _ _)) -> (leftE, paren rightE)- _ -> (leftE, rightE)+ (_, ConstExpr _, ConstExpr _) ->+ (leftE, rightE)+ (_, _, ConstExpr _) ->+ (paren leftE, rightE)+ (_, ConstExpr _, _) ->+ (leftE, paren rightE)+ _ -> (paren leftE, paren rightE) in BinSqlExpr (showBinOp op) expL expR UnExpr op e -> let (op',t) = sqlUnOp op e' = sqlExpr gen e in case t of UnOpFun -> FunSqlExpr op' [e']- UnOpPrefix -> PrefixSqlExpr op' e'+ UnOpPrefix -> PrefixSqlExpr op' (ParensSqlExpr e') UnOpPostfix -> PostfixSqlExpr op' e' AggrExpr op e -> let op' = showAggrOp op e' = sqlExpr gen e- in FunSqlExpr op' [e']+ in AggrFunSqlExpr op' [e'] ConstExpr l -> ConstSqlExpr (sqlLiteral gen l) CaseExpr cs e -> let cs' = [(sqlExpr gen c, sqlExpr gen x)| (c,x) <- cs] e' = sqlExpr gen e
src/Database/HaskellDB/Sql/PostgreSQL.hs view
@@ -40,10 +40,6 @@ postgresqlType :: FieldType -> SqlType postgresqlType BoolT = SqlType "boolean"---- Postgres < 7.1 assumed timestamp meant with a time zone, afterwards,--- 'timestamp with time zone' is now required.-postgresqlType CalendarTimeT = SqlType "timestamp with time zone" postgresqlType t = defaultSqlType generator t postgresqlExpr :: PrimExpr -> SqlExpr
src/Database/HaskellDB/Sql/Print.hs view
@@ -38,7 +38,7 @@ <+> ppAttrs attrs $$ ppTables tables $$ ppWhere criteria- $$ ppGroupBy groupby+ $$ maybe empty ppGroupBy groupby $$ ppOrderBy orderby $$ hsep (map text extra) ppSql (SqlBin op q1 q2) = parens (ppSql q1) $$ text op $$ parens (ppSql q2)@@ -71,16 +71,17 @@ ppWhere :: [SqlExpr] -> Doc ppWhere [] = empty ppWhere es = text "WHERE" - <+> hsep (intersperse (text "AND") (map ppSqlExpr es))+ <+> hsep (intersperse (text "AND")+ (map (parens . ppSqlExpr) es)) -ppGroupBy :: [(SqlColumn, SqlExpr)] -> Doc-ppGroupBy [] = empty-ppGroupBy es = text "GROUP BY" <+> ppGroupAttrs es+ppGroupBy :: Mark -> Doc+ppGroupBy All = error "Should not ever print GroupBy all."+ppGroupBy (Columns es) = text "GROUP BY" <+> ppGroupAttrs es where ppGroupAttrs :: [(SqlColumn, SqlExpr)] -> Doc ppGroupAttrs cs = commaV nameOrExpr cs nameOrExpr :: (SqlColumn, SqlExpr) -> Doc- nameOrExpr (name, ColumnSqlExpr _) = text name+ nameOrExpr (_, ColumnSqlExpr col) = text col nameOrExpr (_, expr) = parens (ppSqlExpr expr) ppOrderBy :: [(SqlExpr,SqlOrder)] -> Doc@@ -172,6 +173,7 @@ PrefixSqlExpr op e -> text op <+> ppSqlExpr e PostfixSqlExpr op e -> ppSqlExpr e <+> text op FunSqlExpr f es -> text f <> parens (commaH ppSqlExpr es)+ AggrFunSqlExpr f es -> text f <> parens (commaH ppSqlExpr es) ConstSqlExpr c -> text c CaseSqlExpr cs el -> text "CASE" <+> vcat (map ppWhen cs) <+> text "ELSE" <+> ppSqlExpr el <+> text "END"