diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/haskelldb.cabal b/haskelldb.cabal --- a/haskelldb.cabal +++ b/haskelldb.cabal @@ -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" -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 diff --git a/src/Database/HaskellDB.hs b/src/Database/HaskellDB.hs --- a/src/Database/HaskellDB.hs +++ b/src/Database/HaskellDB.hs @@ -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 diff --git a/src/Database/HaskellDB/BoundedList.hs b/src/Database/HaskellDB/BoundedList.hs --- a/src/Database/HaskellDB/BoundedList.hs +++ b/src/Database/HaskellDB/BoundedList.hs @@ -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 diff --git a/src/Database/HaskellDB/DBDirect.hs b/src/Database/HaskellDB/DBDirect.hs --- a/src/Database/HaskellDB/DBDirect.hs +++ b/src/Database/HaskellDB/DBDirect.hs @@ -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] \n" + "Usage: " ++ p ++ " [dbdirect-options] \n" footer = unlines $ + "" : + "NOTE: You will probably have to specify the db name in both and . This is because the driver options are specific to each database." : "" : "module: Module name without an extension" : ("driver-options: " ++ diff --git a/src/Database/HaskellDB/DBLayout.hs b/src/Database/HaskellDB/DBLayout.hs --- a/src/Database/HaskellDB/DBLayout.hs +++ b/src/Database/HaskellDB/DBLayout.hs @@ -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 diff --git a/src/Database/HaskellDB/DBSpec/DBInfo.hs b/src/Database/HaskellDB/DBSpec/DBInfo.hs --- a/src/Database/HaskellDB/DBSpec/DBInfo.hs +++ b/src/Database/HaskellDB/DBSpec/DBInfo.hs @@ -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 diff --git a/src/Database/HaskellDB/DBSpec/DBSpecToDBDirect.hs b/src/Database/HaskellDB/DBSpec/DBSpecToDBDirect.hs --- a/src/Database/HaskellDB/DBSpec/DBSpecToDBDirect.hs +++ b/src/Database/HaskellDB/DBSpec/DBSpecToDBDirect.hs @@ -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] diff --git a/src/Database/HaskellDB/DBSpec/DatabaseToDBSpec.hs b/src/Database/HaskellDB/DBSpec/DatabaseToDBSpec.hs --- a/src/Database/HaskellDB/DBSpec/DatabaseToDBSpec.hs +++ b/src/Database/HaskellDB/DBSpec/DatabaseToDBSpec.hs @@ -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, ) diff --git a/src/Database/HaskellDB/Database.hs b/src/Database/HaskellDB/Database.hs --- a/src/Database/HaskellDB/Database.hs +++ b/src/Database/HaskellDB/Database.hs @@ -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 diff --git a/src/Database/HaskellDB/DriverAPI.hs b/src/Database/HaskellDB/DriverAPI.hs --- a/src/Database/HaskellDB/DriverAPI.hs +++ b/src/Database/HaskellDB/DriverAPI.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ExistentialQuantification, Rank2Types #-} ----------------------------------------------------------- -- | -- Module : DriverAPI diff --git a/src/Database/HaskellDB/FieldType.hs b/src/Database/HaskellDB/FieldType.hs --- a/src/Database/HaskellDB/FieldType.hs +++ b/src/Database/HaskellDB/FieldType.hs @@ -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 _ = [] diff --git a/src/Database/HaskellDB/HDBRec.hs b/src/Database/HaskellDB/HDBRec.hs --- a/src/Database/HaskellDB/HDBRec.hs +++ b/src/Database/HaskellDB/HDBRec.hs @@ -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 diff --git a/src/Database/HaskellDB/Optimize.hs b/src/Database/HaskellDB/Optimize.hs --- a/src/Database/HaskellDB/Optimize.hs +++ b/src/Database/HaskellDB/Optimize.hs @@ -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 diff --git a/src/Database/HaskellDB/PrimQuery.hs b/src/Database/HaskellDB/PrimQuery.hs --- a/src/Database/HaskellDB/PrimQuery.hs +++ b/src/Database/HaskellDB/PrimQuery.hs @@ -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 diff --git a/src/Database/HaskellDB/PrintQuery.hs b/src/Database/HaskellDB/PrintQuery.hs --- a/src/Database/HaskellDB/PrintQuery.hs +++ b/src/Database/HaskellDB/PrintQuery.hs @@ -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 diff --git a/src/Database/HaskellDB/Query.hs b/src/Database/HaskellDB/Query.hs --- a/src/Database/HaskellDB/Query.hs +++ b/src/Database/HaskellDB/Query.hs @@ -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 "")) --} diff --git a/src/Database/HaskellDB/Sql.hs b/src/Database/HaskellDB/Sql.hs --- a/src/Database/HaskellDB/Sql.hs +++ b/src/Database/HaskellDB/Sql.hs @@ -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 = [] } diff --git a/src/Database/HaskellDB/Sql/Default.hs b/src/Database/HaskellDB/Sql/Default.hs --- a/src/Database/HaskellDB/Sql/Default.hs +++ b/src/Database/HaskellDB/Sql/Default.hs @@ -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 diff --git a/src/Database/HaskellDB/Sql/PostgreSQL.hs b/src/Database/HaskellDB/Sql/PostgreSQL.hs --- a/src/Database/HaskellDB/Sql/PostgreSQL.hs +++ b/src/Database/HaskellDB/Sql/PostgreSQL.hs @@ -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 diff --git a/src/Database/HaskellDB/Sql/Print.hs b/src/Database/HaskellDB/Sql/Print.hs --- a/src/Database/HaskellDB/Sql/Print.hs +++ b/src/Database/HaskellDB/Sql/Print.hs @@ -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"