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,40 +1,69 @@ Name: haskelldb -Version: 0.10 +Version: 2.2.4 +Cabal-version: >= 1.6 +Build-type: Simple +Homepage: https://github.com/m4dc4p/haskelldb Copyright: The authors -Maintainer: haskelldb-users@lists.sourceforge.net -Author: Daan Leijen, Conny Andersson, Martin Andersson, Mary Bergman, Victor Blomqvist, Bjorn Bringert, Anders Hockersten, Torbjorn Martin, Jeremy Shaw +Maintainer: "Justin Bailey" +Author: Daan Leijen, Conny Andersson, Martin Andersson, Mary Bergman, Victor Blomqvist, Bjorn Bringert, Anders Hockersten, Torbjorn Martin, Jeremy Shaw, Justin Bailey License: BSD3 -build-depends: haskell98, base, mtl -Extensions: ExistentialQuantification, - OverlappingInstances, - UndecidableInstances, - MultiParamTypeClasses -Synopsis: SQL unwrapper for Haskell. -Exposed-Modules: - Database.HaskellDB, - Database.HaskellDB.BoundedList, - Database.HaskellDB.BoundedString, - Database.HaskellDB.DBLayout, - 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.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 -hs-source-dirs: src -ghc-options: -O2 +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.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, + MultiParamTypeClasses, + FunctionalDependencies, + TypeSynonymInstances, + FlexibleInstances, + 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.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 + +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 @@ -5,7 +6,7 @@ -- HWT Group (c) 2003, haskelldb-users@lists.sourceforge.net -- License : BSD-style -- --- Maintainer : haskelldb-users@lists.sourceforge.net +-- Maintainer : "Justin Bailey" -- Stability : experimental -- Portability : non portable -- @@ -39,45 +40,46 @@ -- ----------------------------------------------------------- module Database.HaskellDB - ( Rel, Attr, Expr, Table, Query, OrderExpr - - -- * Records - , HasField, Record, Select, ( # ), ( << ), (<<-), (!), (!.) - - -- * Relational operators - , restrict, table, project - , union, intersect, divide, minus - - -- * Query expressions - , (.==.) , (.<>.), (.<.), (.<=.), (.>.), (.>=.) - , (.&&.) , (.||.) - , (.*.) , (./.), (.%.), (.+.), (.-.), (.++.) - , _not, like, _in, cat, _length - , isNull, notNull, fromNull - , constant, constJust - - , 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(..), Mark(..)) import Database.HaskellDB.Sql.Generate (sqlQuery) import Database.HaskellDB.Sql.Default (defaultSqlGenerator) import Database.HaskellDB.Sql.Print (ppSql) @@ -85,7 +87,12 @@ import Database.HaskellDB.Query import Database.HaskellDB.Database import Text.PrettyPrint.HughesPJ (Doc) +import Data.Foldable (foldr') +-- | Represents a query parameter. Left parameters are indexed +-- by position, while right parameters are named. +type Param = Either Int String + -- | Shows the optimized SQL for the query. instance Show (Query (Rel r)) where showsPrec _ query = shows (showSql query) @@ -104,4 +111,51 @@ -- | Shows the unoptimized SQL query. showSqlUnOpt :: Query (Rel r) -> String -showSqlUnOpt = show . ppSql . sqlQuery defaultSqlGenerator . runQuery +showSqlUnOpt = show . ppSql . sqlQuery defaultSqlGenerator . runQuery + +-- | Get paramaters from a query in order. +queryParams :: Query (Rel r) -> [Param] +queryParams q = snd . indexParams . selectParams . toSelect $ q + where + -- Use foldr so we don't have to reverse parameter list built. + indexParams = foldr' renumber (1, []) + renumber (Just n) (idx, ps) = (idx, Right n : ps) + renumber Nothing (idx, ps) = (idx + 1, Left idx : ps) + toSelect = sqlQuery defaultSqlGenerator . optimize . runQuery + -- | All parameters that are in the select, in the textual order + -- they will appear. + selectParams :: SqlSelect -> [Maybe SqlName] + selectParams select@(SqlSelect { S.attrs = a, S.tables = t, S.criteria = c, S.groupby = g, S.orderby = o}) + = (attrParams a ++) . (tableParams t ++) . (criteriaParams c ++) . + (groupByParams g ++) . orderByParams $ o + where + attrParams = getParams (exprParams . snd) + tableParams = getParams (selectParams . snd) + criteriaParams = getParams exprParams + 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 + -- | All parameters in the expression, in the textual order + -- in which they will appear. + exprParams :: SqlExpr -> [Maybe SqlName] + exprParams (ColumnSqlExpr _) = [] + exprParams (ConstSqlExpr _) = [] + exprParams (ParamSqlExpr p _) = [p] + exprParams (BinSqlExpr _ l r) = exprParams l ++ exprParams r + 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 + exprParams (ListSqlExpr es) = concatMap exprParams es + exprParams (ExistsSqlExpr select) = selectParams select + exprParams PlaceHolderSqlExpr = [] + exprParams (ParensSqlExpr e) = exprParams e + exprParams (CastSqlExpr _ e) = exprParams e + selectParams (SqlBin _ l r) = selectParams l ++ selectParams r + selectParams _ = [] 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 @@ -1396,8 +1402,10 @@ -- | Returns the length of a 'BoundedList'. listBound :: Size n => BoundedList a n -> Int -listBound (_ :: BoundedList a n) = size (undefined :: n) +listBound = size . listBoundType +listBoundType :: BoundedList a n -> n +listBoundType _ = undefined -- | Takes a list and transforms it to a 'BoundedList'. -- If the list doesn\'t fit, Nothing is returned. diff --git a/src/Database/HaskellDB/DBDirect.hs b/src/Database/HaskellDB/DBDirect.hs new file mode 100644 --- /dev/null +++ b/src/Database/HaskellDB/DBDirect.hs @@ -0,0 +1,152 @@ +----------------------------------------------------------- +-- | +-- Module : Database.HaskellDB.DBDirect +-- Copyright : Daan Leijen (c) 1999, daan@cs.uu.nl +-- HWT Group (c) 2003, +-- Bjorn Bringert (c) 2005-2006, bjorn@bringert.net +-- License : BSD-style +-- +-- Maintainer : haskelldb-users@lists.sourceforge.net +-- Stability : experimental +-- Portability : portable +-- +-- DBDirect generates a Haskell module from a database. +-- It first reads the system catalog of the database into +-- a 'Catalog' data type. After that it pretty prints that +-- data structure in an appropiate Haskell module which +-- can be used to perform queries on the database. +-- +----------------------------------------------------------- + +module Database.HaskellDB.DBDirect (dbdirect) where + +import Database.HaskellDB (Database, ) +import Database.HaskellDB.DriverAPI (DriverInterface, connect, requiredOptions, ) +import Database.HaskellDB.DBSpec (dbToDBSpec, dbname) +import Database.HaskellDB.DBSpec.DBSpecToDBDirect (dbInfoToModuleFiles, ) + +import qualified Database.HaskellDB.DBSpec.PPHelpers as PP + +import System.Console.GetOpt (getOpt, ArgOrder(..), OptDescr(..), ArgDescr(..), usageInfo, ) +import System.Environment (getArgs, getProgName, ) +import System.Exit (exitFailure, ) +import System.IO (hPutStrLn, stderr, ) + +import Control.Monad.Error () -- Monad instance for Either +import Control.Monad (when, ) +import Data.List (intersperse, ) + + +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 {dbname = dbName}) + + +data Flags = + Flags { + optHelp :: Bool, + optBoundedStrings :: Bool, + optIdentifierStyle :: PP.MakeIdentifiers + } + +options :: [OptDescr (Flags -> Either String Flags)] +options = + Option ['h'] ["help"] + (NoArg (\flags -> Right $ flags{optHelp = True})) + "show options" : + Option ['b'] ["bounded-strings"] + (NoArg (\flags -> Right $ flags{optBoundedStrings = True})) + "use bounded string types" : + Option [] ["identifier-style"] + (ReqArg (\str flags -> + case str of + "preserve" -> Right $ flags{optIdentifierStyle = PP.mkIdentPreserving} + "camel-case" -> Right $ flags{optIdentifierStyle = PP.mkIdentCamelCase} + _ -> Left $ "unknown identifier style: " ++ str) + "type") + " is one of [preserve, camel-case]" : + [] + +parseOptions :: + [Flags -> Either String Flags] -> Either String Flags +parseOptions = + foldr (=<<) + (Right $ + Flags {optHelp = False, + optBoundedStrings = False, + optIdentifierStyle = PP.mkIdentPreserving}) + +exitWithError :: String -> IO a +exitWithError msg = + hPutStrLn stderr msg >> + hPutStrLn stderr "Try --help option to get detailed info." >> + exitFailure + +dbdirect :: DriverInterface -> IO () +dbdirect driver = + do putStrLn "DB/Direct: Daan Leijen (c) 1999, HWT (c) 2003-2004," + putStrLn " Bjorn Bringert (c) 2005-2007, Henning Thielemann (c) 2008" + putStrLn "" + + argv <- getArgs + let (opts, modAndDrvOpts, errors) = getOpt RequireOrder options argv + when (not (null errors)) + (ioError . userError . concat $ errors) + + flags <- + case parseOptions opts of + Left errMsg -> exitWithError errMsg + Right flags -> return flags + + when (optHelp flags) + (showHelp driver >> exitFailure) + + case modAndDrvOpts of + [] -> exitWithError "Missing module and driver options" + [_] -> exitWithError "Missing driver options" + [moduleName,dbname,drvOpts] -> + do putStrLn "Connecting to database..." + connect driver + (splitOptions drvOpts) + (createModules moduleName dbname + (optBoundedStrings flags) + (optIdentifierStyle flags)) + putStrLn "Done!" + (_:_:restArgs) -> + exitWithError ("Unnecessary arguments: " ++ show restArgs) + + + +splitOptions :: String -> [(String,String)] +splitOptions = map (split2 '=') . split ',' + +split :: Char -> String -> [String] +split _ [] = [] +split g xs = y : split g ys + where (y,ys) = split2 g xs + +split2 :: Char -> String -> (String,String) +split2 g xs = (ys, drop 1 zs) + where (ys,zs) = break (==g) xs + +-- | Shows usage information +showHelp :: DriverInterface -> IO () +showHelp driver = + do p <- getProgName + let header = + "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: " ++ + (concat . intersperse "," . + map (\(name,descr) -> name++"=<"++descr++">") . + requiredOptions) driver) : + [] + hPutStrLn stderr $ (usageInfo header options ++ footer) 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 @@ -20,38 +20,48 @@ dbInfoToDoc,finalizeSpec,constructNonClashingDBInfo) where -import Database.HaskellDB.FieldType -import Data.Char +import qualified Database.HaskellDB.DBSpec.PPHelpers as PP +import Database.HaskellDB.FieldType (FieldDesc, FieldType(BStrT, StringT), ) +import Data.Char (toLower, isAlpha) import Text.PrettyPrint.HughesPJ -- | Defines a database layout, top level -data DBInfo = DBInfo {dbname :: String, -- ^ The name of the database - opts :: DBOptions, -- ^ Any options (i.e whether to use +data DBInfo = DBInfo {dbname :: String -- ^ The name of the database + ,opts :: DBOptions -- ^ Any options (i.e whether to use -- Bounded Strings) - tbls :: [TInfo] -- ^ Tables this database contains + ,tbls :: [TInfo] -- ^ Tables this database contains } - deriving (Eq,Show) + deriving (Show) -data TInfo = TInfo {tname :: String, -- ^ The name of the table - cols :: [CInfo] -- ^ The columns in this table +data TInfo = TInfo {tname :: String -- ^ The name of the table + ,cols :: [CInfo] -- ^ The columns in this table } deriving (Eq,Show) -data CInfo = CInfo {cname :: String, -- ^ The name of this column - descr :: FieldDesc -- ^ The description of this column +data CInfo = CInfo {cname :: String -- ^ The name of this column + ,descr :: FieldDesc -- ^ The description of this column } deriving (Eq,Show) -data DBOptions = DBOptions {useBString :: Bool -- ^ Use Bounded Strings? - } - deriving (Eq,Show) +data DBOptions = DBOptions + {useBString :: Bool -- ^ Use Bounded Strings? + ,makeIdent :: PP.MakeIdentifiers -- ^ Conversion routines from Database identifiers to Haskell identifiers + } +instance Show DBOptions where + showsPrec p opts = + showString "DBOptions {useBString = " . + shows (useBString opts) . + showString "}" + + -- | 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 @@ -130,9 +140,15 @@ -- | Constructs a DBInfo that doesn't cause nameclashes constructNonClashingDBInfo :: DBInfo -> DBInfo constructNonClashingDBInfo dbinfo = - let db' = makeDBNameUnique dbinfo in - if db' == makeDBNameUnique db' then db' - else constructNonClashingDBInfo db' + let db' = makeDBNameUnique dbinfo + in if equalObjectNames db' (makeDBNameUnique db') + then db' + else constructNonClashingDBInfo db' + +equalObjectNames :: DBInfo -> DBInfo -> Bool +equalObjectNames db1 db2 = + dbname db1 == dbname db2 && + tbls db1 == tbls db2 -- | Makes a table name unique among all other table names makeTblNamesUnique :: [TInfo] -> [TInfo] 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 @@ -3,29 +3,32 @@ -- Module : DBSpecToDBDirect -- Copyright : HWT Group (c) 2004, haskelldb-users@lists.sourceforge.net -- License : BSD-style --- +-- -- Maintainer : haskelldb-users@lists.sourceforge.net -- Stability : experimental -- Portability : non-portable -- -- Converts a DBSpec-generated database to a set of --- (FilePath,Doc), that can be used to generate definition --- files usable in HaskellDB (the generation itself is done +-- (FilePath,Doc), that can be used to generate definition +-- files usable in HaskellDB (the generation itself is done -- in DBDirect) -- --- +-- ----------------------------------------------------------- module Database.HaskellDB.DBSpec.DBSpecToDBDirect - (specToHDB, dbInfoToModuleFiles) + (specToHDB, dbInfoToModuleFiles) where -import Database.HaskellDB.BoundedString -import Database.HaskellDB.FieldType -import Database.HaskellDB -import Database.HaskellDB.PrimQuery +import Database.HaskellDB.FieldType (toHaskellType, ) + import Database.HaskellDB.DBSpec.DBInfo + (TInfo(TInfo), CInfo(CInfo), DBInfo, + descr, cols, tname, cname, tbls, dbInfoToDoc, opts, makeIdent, + finalizeSpec, constructNonClashingDBInfo, ) import Database.HaskellDB.DBSpec.PPHelpers + (MakeIdentifiers, moduleName, toType, identifier, checkChars, + ppComment, newline, ) import Control.Monad (unless) import Data.List (isPrefixOf) @@ -36,16 +39,18 @@ 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. Not currently in use since -fcontext-stackXX --- is a static option, and thus can't be used in options pragmas. +-- of the generated file. contextStackPragma :: TInfo -> Doc contextStackPragma ti - = text "-- NOTE: use GHC flag" <+> text flag <+> text "with this module" --- = text "{-# OPTIONS" <+> text flag <+> text "#-}" + = text "{-# OPTIONS_GHC" <+> text flag <+> text "#-}" where flag = "-fcontext-stack" ++ (show (40 + length (cols ti))) --- | All imports generated files have dependencies on. Nowadays, this +-- | All imports generated files have dependencies on. Nowadays, this -- should only be Database.HaskellDB.DBLayout imports :: Doc imports = text "import Database.HaskellDB.DBLayout" @@ -54,16 +59,16 @@ dbInfoToModuleFiles :: FilePath -- ^ base directory -> String -- ^ top-level module name -> DBInfo -> IO () -dbInfoToModuleFiles d name = +dbInfoToModuleFiles d name = createModules d name . specToHDB name . finalizeSpec --- | Creates modules +-- | Creates modules createModules :: FilePath -- ^ Base directory -> String -- ^ Name of directory and top-level module for the database modules -> [(String,Doc)] -- ^ Module names and module contents -> IO () createModules basedir dbname files - = do + = do let dir = withPrefix basedir (replace '.' '/' dbname) createPath dir mapM_ (\ (name,doc) -> writeFile (moduleNameToFile basedir name) @@ -99,7 +104,7 @@ exists <- doesDirectoryExist p unless exists (createDirectory p) --- | Converts a database specification to a set of module names +-- | Converts a database specification to a set of module names -- and module contents. The first element of the returned list -- is the top-level module. specToHDB :: String -- ^ Top level module name @@ -108,9 +113,9 @@ -- | Does the actual conversion work genDocs :: String -- ^ Top-level module name - -> DBInfo + -> DBInfo -> [(String,Doc)] -- ^ list of module name, module contents pairs -genDocs name dbinfo +genDocs name dbinfo = (name, header $$ text "module" <+> text name <+> text "where" @@ -122,83 +127,96 @@ $$ dbInfoToDoc dbinfo) : rest where - rest = [tInfoToModule name t | t <- tbls dbinfo, hasName t] + rest = map (tInfoToModule (makeIdent (opts dbinfo)) name) $ + filter hasName $ tbls dbinfo hasName TInfo{tname=name} = name /= "" tbnames = map fst rest - + -- | Makes a module from a TInfo -tInfoToModule :: String -- ^ The name of our main module - -> TInfo +tInfoToModule :: MakeIdentifiers + -> String -- ^ The name of our main module + -> TInfo -> (String,Doc) -- ^ Module name and module contents -tInfoToModule dbname tinfo@TInfo{tname=name,cols=col} +tInfoToModule mi dbname tinfo@TInfo{tname=name,cols=col} = (modname, + languageOptions $$ contextStackPragma tinfo $$ header $$ text "module" <+> text modname <+> text "where" <> newline $$ imports <> newline + $$ ppComment ["Table type"] + <> newline + $$ ppTableType mi tinfo + <> newline $$ ppComment ["Table"] - $$ ppTable tinfo + $$ ppTable mi tinfo $$ ppComment ["Fields"] - $$ if col == [] then empty -- no fields, don't do any weird shit - else vcat (map ppField (columnNamesTypes tinfo))) - where modname = dbname ++ "." ++ moduleName name + $$ if null col + then empty -- no fields, don't do anything weird + else vcat (map (ppField mi) (columnNamesTypes tinfo))) + where modname = dbname ++ "." ++ moduleName mi name +ppTableType :: MakeIdentifiers -> TInfo -> Doc +ppTableType mi (TInfo { tname = tiName, cols = tiColumns }) = + hang decl 4 types + where + decl = text "type" <+> text (toType mi tiName) <+> text "=" + types = ppColumns mi tiColumns + -- | Pretty prints a TableInfo -ppTable :: TInfo -> Doc -ppTable (TInfo tiName tiColumns) = - hang (text (identifier tiName) <+> text "::" <+> text "Table") 4 - (parens (ppColumns tiColumns) - <> newline) - $$ - text (identifier tiName) <+> text "=" <+> - hang (text "baseTable" <+> - doubleQuotes (text (checkChars tiName)) <+> - text "$") 0 - (vcat $ punctuate (text " #") (map ppColumnValue tiColumns)) - <> newline +ppTable :: MakeIdentifiers -> TInfo -> Doc +ppTable mi (TInfo tiName tiColumns) = + hang (text (identifier mi tiName) <+> text "::" <+> text "Table") 4 + (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 -- | Pretty prints a list of ColumnInfo -ppColumns :: [CInfo] -> Doc -ppColumns [] = text "" -ppColumns [c] = parens (ppColumnType c <+> text "RecNil") -ppColumns (c:cs) = parens (ppColumnType c $$ ppColumns cs) +ppColumns _ [] = text "" +ppColumns mi [c] = parens (ppColumnType mi c <+> text "RecNil") +ppColumns mi (c:cs) = parens (ppColumnType mi c $$ ppColumns mi cs) --- | Pretty prints the type field in a ColumnInfo -ppColumnType :: CInfo -> Doc -ppColumnType (CInfo ciName (ciType,ciAllowNull)) - = text "RecCons" <+> - ((text $ toType ciName) <+> parens (text "Expr" - <+> (if (ciAllowNull) - then parens (text "Maybe" <+> text (toHaskellType ciType)) - else text (toHaskellType ciType) - ))) +-- | Pretty prints the type field in a ColumnInfo +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) + ))) -- | Pretty prints the value field in a ColumnInfo -ppColumnValue :: CInfo -> Doc -ppColumnValue (CInfo ciName _) - = text "hdbMakeEntry" <+> text (toType ciName) +ppColumnValue :: MakeIdentifiers -> CInfo -> Doc +ppColumnValue mi (CInfo ciName _) + = text "hdbMakeEntry" <+> text (toType mi ciName) -- | Pretty prints Field definitions -ppField :: (String,String) -> Doc -ppField (name,typeof) = - ppComment [toType name ++ " Field"] +ppField :: MakeIdentifiers -> (String, String) -> Doc +ppField mi (name,typeof) = + ppComment [toType mi name ++ " Field"] <> newline $$ text "data" <+> bname <+> equals <+> bname -- <+> text "deriving Show" <> newline $$ - hang (text "instance FieldTag" <+> bname <+> text "where") 4 - (text "fieldName _" <+> equals <+> doubleQuotes + hang (text "instance FieldTag" <+> bname <+> text "where") 4 + (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 name) - iname = text (identifier name) + bname = text (toType mi name) + iname = text (identifier mi name) -- | Extracts all the column names from a TableInfo columnNames :: TInfo -> [String] @@ -206,7 +224,7 @@ -- | Extracts all the column types from a TableInfo columnTypes :: TInfo -> [String] -columnTypes table = +columnTypes table = [if b then ("(Maybe " ++ t ++ ")") else t | (t,b) <- zippedlist] where zippedlist = zip typelist null_list @@ -215,5 +233,5 @@ -- | Combines the results of columnNames and columnTypes columnNamesTypes :: TInfo -> [(String,String)] -columnNamesTypes table@(TInfo tname fields) +columnNamesTypes table@(TInfo tname fields) = zip (columnNames table) (columnTypes table) 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,18 +17,23 @@ (dbToDBSpec) where -import Database.HaskellDB -import Database.HaskellDB.FieldType +import Database.HaskellDB.Database (Database, tables, describe, ) import Database.HaskellDB.DBSpec.DBInfo + (DBInfo, makeCInfo, makeTInfo, makeDBSpec, + DBOptions(DBOptions), useBString, makeIdent, ) +import qualified Database.HaskellDB.DBSpec.PPHelpers as PP + + -- | Connects to a database and generates a specification from it dbToDBSpec :: Bool -- ^ Use bounded strings? + -> PP.MakeIdentifiers -- ^ style of generated Haskell identifiers, cOLUMN_NAME vs. columnName -> String -- ^ the name our database should have -> Database -- ^ the database connection -> IO DBInfo -- ^ return a DBInfo -dbToDBSpec useBStr name dbconn +dbToDBSpec useBStr mkIdent name dbconn = do ts <- tables dbconn descs <- mapM (describe dbconn) ts let cinfos = map (map $ uncurry makeCInfo) descs let tinfos = map (uncurry makeTInfo) (zip ts cinfos) - return $ makeDBSpec name (DBOptions {useBString = useBStr}) tinfos + return $ makeDBSpec name (DBOptions {useBString = useBStr, makeIdent = mkIdent }) tinfos diff --git a/src/Database/HaskellDB/DBSpec/PPHelpers.hs b/src/Database/HaskellDB/DBSpec/PPHelpers.hs --- a/src/Database/HaskellDB/DBSpec/PPHelpers.hs +++ b/src/Database/HaskellDB/DBSpec/PPHelpers.hs @@ -3,19 +3,19 @@ -- Module : PPHelpers -- Copyright : HWT Group (c) 2004, haskelldb-users@lists.sourceforge.net -- License : BSD-style --- +-- -- Maintainer : haskelldb-users@lists.sourceforge.net -- Stability : experimental -- Portability : non-portable -- -- Various functions used when pretty printing stuff -- --- +-- ----------------------------------------------------------- module Database.HaskellDB.DBSpec.PPHelpers where -- no explicit export, we want ALL of it -import Data.Char +import Data.Char (toLower, toUpper, isAlpha, isAlphaNum, ) import Text.PrettyPrint.HughesPJ newline = char '\n' @@ -28,7 +28,7 @@ where commentLine = text (replicate 75 '-') commentText s = text ("-- " ++ s) - + ----------------------------------------------------------- -- Create valid Names ----------------------------------------------------------- @@ -36,12 +36,48 @@ | otherwise = name where baseName = reverse (takeWhile (/='\\') (reverse name)) - - -moduleName = checkChars . checkUpper -identifier = checkChars . checkKeyword . checkLower -toType = checkChars . checkKeyword . checkUpper + +data MakeIdentifiers = + MakeIdentifiers + { moduleName, identifier, toType :: String -> String } + +mkIdentPreserving = + MakeIdentifiers + { + moduleName = checkChars . checkUpper, + identifier = checkChars . checkKeyword . checkLower, + toType = checkChars . checkKeyword . checkUpper + } + +mkIdentCamelCase = + MakeIdentifiers + { + moduleName = checkChars . toUpperCamelCase, + identifier = checkChars . checkKeyword . toLowerCamelCase, + toType = checkChars . checkKeyword . toUpperCamelCase + } + + +toLowerCamelCase s@(_:_) = + let (h : rest) = split ('_'==) $ dropWhile ('_'==) $ map toLower s + in concat $ checkLower h : map (checkUpperDef '_') rest +toLowerCamelCase [] = + error "toLowerCamelCase: identifier must be non-empty" + +toUpperCamelCase s@(_:_) = + let (h : rest) = split ('_'==) $ dropWhile ('_'==) $ map toLower s + in concat $ checkUpper h : map (checkUpperDef '_') rest +toUpperCamelCase [] = + error "toUpperCamelCase: identifier must be non-empty" + +{- | +Generalization of 'words' and 'lines' to any separating character set. +-} +split :: Eq a => (a -> Bool) -> [a] -> [[a]] +split p = + foldr (\ x yt@ ~(y:ys) -> (if p x then ([]:yt) else ((x:y):ys)) ) [[]] + checkChars s = map replace s where replace c | isAlphaNum c = c @@ -58,16 +94,22 @@ , "do", "return" , "let", "in" , "case", "of" - , "if", "then", "else" + , "if", "then", "else" , "id", "zip","baseTable" ] -checkUpper "" = error "Empty name from database?" -checkUpper s@(x:xs) | isUpper x = s - | isLower x = toUpper x : xs - | otherwise = 'X' : s -- isNumeric? +checkUpper "" = error "Empty name from database?" +checkUpper s = checkUpperDef 'X' s -checkLower "" = error "Empty name from database?" -checkLower s@(x:xs) | isLower x = s - | isUpper x = toLower x : xs - | otherwise = 'x' : s -- isNumeric? +checkLower "" = error "Empty name from database?" +checkLower s = checkLowerDef 'x' s + +checkUpperDef _ "" = "" +checkUpperDef d s@(x:xs) + | isAlpha x = toUpper x : xs + | otherwise = d : s -- isDigit? + +checkLowerDef _ "" = "" +checkLowerDef d s@(x:xs) + | isAlpha x = toLower x : xs + | otherwise = d : s -- isDigit? 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,33 +104,37 @@ , 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 (_::Rel (RecCons f (Expr a) er)) (f:fs) stmt = + getRec vfs c (f:fs) stmt = do x <- getValue vfs stmt f - r <- getRec vfs (undefined :: Rel er) fs stmt + r <- getRec vfs (recTailType c) fs stmt return (RecCons x . r) +recTailType :: Rel (RecCons f (Expr a) er) -> Rel er +recTailType _ = undefined + class GetValue a where getValue :: GetInstances s -> s -> String -> IO a @@ -137,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 @@ -145,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) @@ -174,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 () @@ -193,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 @@ -232,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 @@ -18,6 +19,7 @@ MonadIO, defaultdriver, getOptions, + getAnnotatedOptions, getGenerator ) where @@ -36,12 +38,19 @@ -- | Interface which drivers should implement. -- The 'connect' function takes some driver specific name, value pairs -- use to setup the database connection, and a database action to run. +-- 'requiredOptions' lists all required options with a short description, +-- that is printed as help in the DBDirect program. data DriverInterface = DriverInterface - { connect :: forall m a. MonadIO m => [(String,String)] -> (Database -> m a) -> m a } + { connect :: forall m a. MonadIO m => [(String,String)] -> (Database -> m a) -> m a, + requiredOptions :: [(String, String)] + } -- | Default dummy driver, real drivers should overload this defaultdriver :: DriverInterface -defaultdriver = DriverInterface {connect = undefined} +defaultdriver = + DriverInterface { + connect = error "DriverAPI.connect: not implemented", + requiredOptions = error "DriverAPI.requiredOptions: not implemented"} -- | Can be used by drivers to get option values from the given -- list of name, value pairs. @@ -55,6 +64,17 @@ case lookup x ys of Nothing -> fail $ "Missing field " ++ x Just v -> liftM (v:) $ getOptions xs ys + +-- | Can be used by drivers to get option values from the given +-- list of name, value pairs. +-- It is intended for use with the 'requiredOptions' value of the driver. +getAnnotatedOptions :: Monad m => + [(String,String)] -- ^ names and descriptions of options to get + -> [(String,String)] -- ^ options given + -> m [String] -- ^ a list of the same length as the first argument + -- with the values of each option. Fails in the given + -- monad if any options is not found. +getAnnotatedOptions opts = getOptions (map fst opts) -- | Gets an 'SqlGenerator' from the "generator" option in the given list. -- Currently available generators: "mysql", "postgresql", "sqlite", "default" 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 @@ -14,12 +16,17 @@ -- ----------------------------------------------------------- module Database.HaskellDB.FieldType - (FieldDesc, FieldType(..), toHaskellType) where + (FieldDesc, FieldType(..), toHaskellType, ExprType(..) + , ExprTypes(..), queryFields) where import Data.Dynamic import System.Time +import Data.Time.LocalTime +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) -- | The type and @nullable@ flag of a database column type FieldDesc = (FieldType, Bool) @@ -32,9 +39,26 @@ | DoubleT | BoolT | CalendarTimeT + | LocalTimeT | BStrT Int deriving (Eq,Ord,Show,Read) +-- | Class which retrieves a field description from a given type. +-- Instances are provided for most concrete types. Instances +-- for Maybe automatically make the field nullable, and instances +-- for all (Expr a) types where a has an ExprType instance allows +-- type information to be recovered from a given column expression. +class ExprType e where + fromHaskellType :: e -> FieldDesc + +-- | Class which returns a list of field descriptions. Gets the +-- descriptions of all columns in a Record/query. Most useful when +-- the columns associated with each field in a (Rel r) type must be +-- recovered. Note that this occurs at the type level only and no +-- values are inspected. +class ExprTypes r where + fromHaskellTypes :: r -> [FieldDesc] + toHaskellType :: FieldType -> String toHaskellType StringT = "String" toHaskellType IntT = "Int" @@ -42,10 +66,75 @@ toHaskellType DoubleT = "Double" toHaskellType BoolT = "Bool" toHaskellType CalendarTimeT = "CalendarTime" +toHaskellType LocalTimeT = "LocalTime" toHaskellType (BStrT a) = "BStr" ++ show a -instance Typeable CalendarTime where -- not available in standard libraries - typeOf _ = mkTyConApp (mkTyCon "System.Time.CalendarTime") [] +-- | Given a query, returns a list of the field names and their +-- types used by the query. Useful for recovering field information +-- once a query has been built up. +queryFields :: (ShowLabels r, ExprTypes r) => Query (Rel r) -> [(String, FieldDesc)] +queryFields def = zip (labels query) types + where + query = unRel . snd . runQueryRel $ def + types = fromHaskellTypes query + unRel :: (Rel r) -> r + unRel r = undefined -- Only used to get to type-level information. -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) + +instance (ExprType a) => ExprType (Expr a) where + fromHaskellType e = + let unExpr :: Expr a -> a + unExpr _ = undefined + in fromHaskellType . unExpr $ e + +instance (ExprType a) => ExprType (Rel a) where + fromHaskellType e = + let unRel :: Rel a -> a + unRel _ = undefined + in fromHaskellType . unRel $ e + +instance ExprType Bool where + fromHaskellType _ = (BoolT, False) + +instance ExprType String where + fromHaskellType _ = (StringT, False) + +instance ExprType Int where + fromHaskellType _ = (IntT, False) + +instance ExprType Integer where + fromHaskellType _ = (IntegerT, False) + +instance ExprType Double where + fromHaskellType _ = (DoubleT, False) + +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 _ = [] + +instance (ExprType e, ExprTypes r) => ExprTypes (RecCons f e r) where + fromHaskellTypes ~f@(RecCons e r) = + let getFieldType :: RecCons f a r -> a + getFieldType = undefined + in (fromHaskellType . getFieldType $ f) : fromHaskellTypes r + +instance (ExprTypes r) => ExprTypes (Record r) where + fromHaskellTypes r = fromHaskellTypes (r RecNil) + +instance (ExprTypes r) => ExprTypes (Rel r) where + fromHaskellTypes r = + let unRel :: Rel a -> a + unRel _ = undefined + in fromHaskellTypes . unRel $ r 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 @@ -103,8 +106,11 @@ (!) :: r -> f -> a instance SelectField f r a => Select (l f a) (Record r) a where - (!) r (_::l f a) = selectField (undefined::f) r + (!) r l = selectField (labelType l) r +labelType :: l f a -> f +labelType _ = undefined + -- | Class which does the actual work of -- getting the value of a field from a record. -- FIXME: would like the dependency f r -> a here, but @@ -116,10 +122,10 @@ -> a -- ^ Field value instance SelectField f (RecCons f a r) a where - selectField _ (RecCons x _) = x + selectField _ ~(RecCons x _) = x instance SelectField f r a => SelectField f (RecCons g b r) a where - selectField f (RecCons _ r) = selectField f r + selectField f ~(RecCons _ r) = selectField f r instance SelectField f r a => SelectField f (Record r) a where selectField f r = selectField f (r RecNil) @@ -127,7 +133,7 @@ -- * Field update setField :: SetField f r a => l f a -> a -> r -> r -setField (_::l f a) = setField_ (undefined::f) +setField l = setField_ (labelType l) class SetField f r a where -- | Sets the value of a field in a record. @@ -137,10 +143,10 @@ -> r -- ^ New record instance SetField f (RecCons f a r) a where - setField_ _ y (RecCons _ r) = RecCons y r + setField_ _ y ~(RecCons _ r) = RecCons y r instance SetField f r a => SetField f (RecCons g b r) a where - setField_ l y (RecCons f r) = RecCons f (setField_ l y r) + setField_ l y ~(RecCons f r) = RecCons f (setField_ l y r) instance SetField f r a => SetField f (Record r) a where setField_ f y r = \e -> setField_ f y (r e) @@ -157,14 +163,17 @@ -- | Get the label name of a record entry. consFieldName :: FieldTag f => RecCons f a r -> String -consFieldName (_::RecCons f a r) = fieldName (undefined::f) +consFieldName = fieldName . consFieldType +consFieldType :: RecCons f a r -> f +consFieldType _ = undefined + class ShowLabels r where recordLabels :: r -> [String] instance ShowLabels RecNil where recordLabels _ = [] instance (FieldTag f,ShowLabels r) => ShowLabels (RecCons f a r) where - recordLabels x@(RecCons _ r) = consFieldName x : recordLabels r + recordLabels ~x@(RecCons _ r) = consFieldName x : recordLabels r instance ShowLabels r => ShowLabels (Record r) where recordLabels r = recordLabels (r RecNil) @@ -182,7 +191,7 @@ instance (FieldTag a, Show b, ShowRecRow c) => ShowRecRow (RecCons a b c) where - showRecRow r@(RecCons x fs) = (consFieldName r, shows x) : showRecRow fs + showRecRow ~r@(RecCons x fs) = (consFieldName r, shows x) : showRecRow fs instance ShowRecRow r => ShowRecRow (Record r) where showRecRow r = showRecRow (r RecNil) 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,14 +18,14 @@ 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 optimize :: PrimQuery -> PrimQuery optimize = hacks . mergeProject - . removeEmpty + . removeEmpty . removeDead . pushRestrict . optimizeExprs @@ -44,13 +44,13 @@ -- PostgreSQL, since we use SELECT DISTINCT. includeOrderFieldsInSelect :: PrimQuery -> PrimQuery includeOrderFieldsInSelect = - foldPrimQuery (Empty, BaseTable, proj, Restrict, Binary, Special) + foldPrimQuery (Empty, BaseTable, proj, Restrict, Binary, Group, Special) where proj ass p = Project (ass++ass') p where ass' = [(a, AttrExpr a) | a <- new ] new = orderedBy p \\ concatMap (attrInExpr . snd) ass orderedBy = foldPrimQuery ([], \_ _ -> [], \_ _ -> [], - \_ _ -> [], \_ _ _ -> [], special) + \_ _ -> [], \_ _ _ -> [], \_ _ -> [], special) special (Order es) p = attrInOrder es `union` p special _ p = p @@ -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,19 +90,32 @@ removeD live (Special (Order xs) query) = Special (Order xs) (removeD (live ++ attrInOrder xs) query) -removeD live query - = query +removeD live (Group cols query) = Group newAssoc (removeD newLive query) + where + 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 - = foldPrimQuery (Empty, BaseTable, project, restrict, binary, special) +removeEmpty + = foldPrimQuery (Empty, BaseTable, project, restrict, binary, group, special) where -- Messes up queries without a table, e.g. constant queries -- disabled by Bjorn Bringert 2004-04-08 --project assoc Empty = Empty - project assoc query | null assoc = Empty + project assoc query | null assoc = query | otherwise = Project assoc query restrict x Empty = Empty @@ -147,45 +131,68 @@ Difference -> query _ -> Empty binary op query1 query2 = Binary op query1 query2 - + group _ Empty = Empty + group cols query = Group cols query -- | Collapse adjacent projections mergeProject :: PrimQuery -> PrimQuery -mergeProject - = foldPrimQuery (Empty,BaseTable,project,Restrict,Binary,Special) +mergeProject 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) + -- 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 @@ -195,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)) @@ -204,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)) @@ -239,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 @@ -261,14 +283,14 @@ optimizeExprs :: PrimQuery -> PrimQuery -optimizeExprs = foldPrimQuery (Empty, BaseTable, Project, restr, Binary, Special) +optimizeExprs = foldPrimQuery (Empty, BaseTable, Project, restr, Binary, Group, Special) where restr e q | exprIsTrue e' = q | otherwise = Restrict e' q where e' = optimizeExpr e optimizeExpr :: PrimExpr -> PrimExpr -optimizeExpr = foldPrimExpr (AttrExpr,ConstExpr,bin,un,AggrExpr,CaseExpr,ListExpr) +optimizeExpr = foldPrimExpr (AttrExpr,ConstExpr,bin,un,AggrExpr,CaseExpr,ListExpr,ParamExpr,FunExpr, CastExpr) where bin OpAnd e1 e2 | exprIsFalse e1 || exprIsFalse e2 = exprFalse 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 @@ -18,7 +18,7 @@ -- * Type Declarations -- ** Types - TableName, Attribute, Scheme, Assoc + TableName, Attribute, Scheme, Assoc, Name -- ** Data types , PrimQuery(..), RelOp(..), SpecialOp(..) @@ -30,7 +30,7 @@ , extend, times , attributes, attrInExpr, attrInOrder , substAttr - , isAggregate + , isAggregate, isConstant , foldPrimQuery, foldPrimExpr ) where @@ -49,6 +49,7 @@ type TableName = String type Attribute = String +type Name = String type Scheme = [Attribute] type Assoc = [(Attribute,PrimExpr)] @@ -56,6 +57,7 @@ data PrimQuery = BaseTable TableName Scheme | Project Assoc PrimQuery | Restrict PrimExpr PrimQuery + | Group Assoc PrimQuery | Binary RelOp PrimQuery PrimQuery | Special SpecialOp PrimQuery | Empty @@ -63,6 +65,7 @@ data RelOp = Times | Union + | UnionAll | Intersect | Divide | Difference @@ -70,6 +73,7 @@ data SpecialOp = Order [OrderExpr] | Top Int + | Offset Int deriving (Show) data OrderExpr = OrderExpr OrderOp PrimExpr @@ -85,6 +89,9 @@ | ConstExpr Literal | CaseExpr [(PrimExpr,PrimExpr)] PrimExpr | ListExpr [PrimExpr] + | ParamExpr (Maybe Name) PrimExpr + | FunExpr Name [PrimExpr] + | CastExpr Name PrimExpr -- ^ Cast an expression to a given type. deriving (Read,Show) data Literal = NullLit @@ -147,12 +154,14 @@ attributes (Binary op q1 q2) = case op of Times -> attr1 `union` attr2 Union -> attr1 + UnionAll -> attr1 Intersect -> attr1 Divide -> attr1 Difference -> attr1 where attr1 = attributes q1 attr2 = attributes q2 +attributes (Group _ qry) = attributes qry -- | Returns a one-to-one association of a -- schema. ie. @assocFromScheme ["name","city"]@ becomes: @@ -164,15 +173,18 @@ -- | Returns all attributes in an expression. attrInExpr :: PrimExpr -> Scheme -attrInExpr = foldPrimExpr (attr,scalar,binary,unary,aggr,_case,list) +attrInExpr = concat . foldPrimExpr (attr,scalar,binary,unary,aggr,_case,list,param,func, cast) where - attr name = [name] - scalar s = [] + attr name = [[name]] + scalar s = [[]] binary op x y = x ++ y unary op x = x aggr op x = x _case cs el = concat (uncurry (++) (unzip cs)) ++ el list xs = concat xs + param _ _ = [[]] + func _ es = concat es + cast _ expr = expr -- | Returns all attributes in a list of ordering expressions. attrInOrder :: [OrderExpr] -> Scheme @@ -181,30 +193,47 @@ -- | Substitute attribute names in an expression. substAttr :: Assoc -> PrimExpr -> PrimExpr substAttr assoc - = foldPrimExpr (attr,ConstExpr,BinExpr,UnExpr,AggrExpr,CaseExpr,ListExpr) + = foldPrimExpr (attr,ConstExpr,BinExpr,UnExpr,AggrExpr,CaseExpr,ListExpr,ParamExpr,FunExpr,CastExpr) where attr name = case (lookup name assoc) of Just x -> x Nothing -> AttrExpr name +-- | Determines if a primitive expression represents a constant +-- or is an expression only involving constants. +isConstant :: PrimExpr -> Bool +isConstant x = countAttr x == 0 + where + 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 _ x y = x + y + unary _ x = x + aggr _ x = x + cast _ n = n + isAggregate :: PrimExpr -> Bool isAggregate x = countAggregate x > 0 countAggregate :: PrimExpr -> Int countAggregate - = foldPrimExpr (const 0, const 0, binary, unary, aggr, _case, list) + = foldPrimExpr (const 0, const 0, binary, unary, aggr, _case, list,(\_ _ -> 0), (\_ n -> sum n), cast) where binary op x y = x + y unary op x = x aggr op x = x + 1 _case cs el = sum (map (uncurry (+)) cs) + el list xs = sum xs + cast _ e = e -- | Fold on 'PrimQuery' foldPrimQuery :: (t, TableName -> Scheme -> t, Assoc -> t -> t, PrimExpr -> t -> t, RelOp -> t -> t -> t, - SpecialOp -> t -> t) -> PrimQuery -> t -foldPrimQuery (empty,table,project,restrict,binary,special) + Assoc -> t -> t, SpecialOp -> t -> t) -> PrimQuery -> t +foldPrimQuery (empty,table,project,restrict,binary,group,special) = fold where fold (Empty) = empty @@ -216,13 +245,15 @@ = restrict expr (fold query) fold (Binary op query1 query2) = binary op (fold query1) (fold query2) + fold (Group assocs query) + = group assocs (fold query) fold (Special op query) = special op (fold query) -- | Fold on 'PrimExpr' foldPrimExpr :: (Attribute -> t, Literal -> t, BinOp -> t -> t -> t, UnOp -> t -> t, AggrOp -> t -> t, - [(t,t)] -> t -> t, [t] -> t) -> PrimExpr -> t -foldPrimExpr (attr,scalar,binary,unary,aggr,_case,list) + [(t,t)] -> t -> t, [t] -> t, Maybe Name -> t -> t, Name -> [t] -> t, Name -> t -> t) -> PrimExpr -> t +foldPrimExpr (attr,scalar,binary,unary,aggr,_case,list,param,fun,cast) = fold where fold (AttrExpr name) = attr name @@ -232,5 +263,8 @@ fold (AggrExpr op x) = aggr op (fold x) fold (CaseExpr cs el) = _case (map (both fold) cs) (fold el) fold (ListExpr xs) = list (map fold xs) + fold (ParamExpr n value) = param n (fold value) + fold (FunExpr n exprs) = fun n (map fold exprs) + fold (CastExpr n expr) = cast n (fold expr) both f (x,y) = (f x, f y) diff --git a/src/Database/HaskellDB/PrintQuery.hs b/src/Database/HaskellDB/PrintQuery.hs new file mode 100644 --- /dev/null +++ b/src/Database/HaskellDB/PrintQuery.hs @@ -0,0 +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 + , 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,46 +20,49 @@ ----------------------------------------------------------- module Database.HaskellDB.Query ( -- * Data and class declarations - Rel(..), Attr(..), Table(..), Query, Expr(..), 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 , (.==.) , (.<>.), (.<.), (.<=.), (.>.), (.>=.) , (.&&.) , (.||.) - , (.*.) , (./.), (.%.), (.+.), (.-.), (.++.) + , (.*.), (./.), (.+.), (.-.), (.%.), (.++.) , (<<), (<<-) -- * Function declarations - , project, restrict, table - , union, intersect, divide, minus + , project, restrict, table, unique + , union, unionAll, intersect, divide, minus , _not, like, _in, cat, _length , isNull, notNull - , fromNull - , constant, constJust - , count, _sum, _max, _min, avg + , 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 - , 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 .+.,.-. @@ -76,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 @@ -116,9 +122,9 @@ class ExprC e where -- | Get the underlying untyped 'PrimExpr'. primExpr :: e a -> PrimExpr -instance ExprC Expr where primExpr (Expr e) = e -instance ExprC ExprAggr where primExpr (ExprAggr e) = e -instance ExprC ExprDefault where primExpr (ExprDefault e) = e +instance ExprC Expr where primExpr ~(Expr e) = e +instance ExprC ExprAggr where primExpr ~(ExprAggr e) = e +instance ExprC ExprDefault where primExpr ~(ExprDefault e) = e -- | Class of expressions that can be used with 'insert'. class ExprC e => InsertExpr e @@ -131,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 @@ -144,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 @@ -160,16 +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 ------------------------------------------------------------ --- Basic relational operators ------------------------------------------------------------ +-- | Creates a single-field record from an attribute and a table. Useful +-- for building projections that will re-use the same attribute name. @copy attr tbl@ is +-- equivalent to: +-- +-- @attr .=. (tbl .!. attr)@ +-- +copy :: (HasField f r) => Attr f a -> Rel r -> Record (RecCons f (Expr a) RecNil) +copy attr tbl = attr << tbl ! attr +-- | 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 @@ -183,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 @@ -193,12 +243,40 @@ updatePrimQuery (extend assoc) return (Rel alias scheme) - -- | Restricts the records to only those who evaluates the -- expression to True. restrict :: Expr Bool -> Query () restrict (Expr primExpr) = updatePrimQuery_ (Restrict primExpr) +-- | Restricts the relation given to only return unique records. Upshot +-- is all projected attributes will be 'grouped'. +unique :: Query () +unique = Query (\(i, primQ) -> + -- Add all non-aggregate expressions in the query + -- to a groupby association list. This list holds the name + -- of the expression and the expression itself. Those expressions + -- will later by added to the groupby list in the SqlSelect built. + case nonAggr primQ of + [] -> ((), (i + 1, primQ)) -- No non-aggregate expressions - no-op. + newCols -> ((), (i + 1, Group newCols primQ))) + where + -- Find all non-aggregate expressions and convert + -- them to attribute expressions for use in group by. + nonAggr :: PrimQuery -> Assoc + nonAggr p = map toAttrExpr . filter (not . isAggregate . snd) . projected $ p + toAttrExpr (col, _) = (col, AttrExpr col) + -- Find all projected columns from subqueries. + projected :: PrimQuery -> Assoc + projected (Project cols q) = cols + projected (Restrict _ q) = projected q + projected (Binary _ q1 q2) = projected q1 ++ projected q2 + projected (BaseTable tblName cols) = zip cols (map AttrExpr cols) + projected (Special _ q) = projected q + -- Group and Empty are no-ops + projected (Group _ _) = [] + projected Empty = [] + + ----------------------------------------------------------- -- Binary operations ----------------------------------------------------------- @@ -207,9 +285,8 @@ binrel op (Query q1) (Query q2) = Query (\(i,primQ) -> let (Rel a1 scheme1,(j,primQ1)) = q1 (i,primQ) - (Rel a2 scheme2,(k,primQ2)) = q2 (j,primQ) - - alias = k + (Rel a2 scheme2,(alias,primQ2)) = q2 (j,primQ) + scheme = scheme1 assoc1 = zip (map (fresh alias) scheme1) @@ -221,13 +298,17 @@ r2 = Project assoc2 primQ2 r = Binary op r1 r2 in - (Rel alias scheme,(k+1,times r primQ)) ) + (Rel alias scheme,(alias + 1, times r primQ)) ) -- | Return all records which are present in at least -- one of the relations. 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 @@ -260,20 +341,38 @@ 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) - ----------------------------------------------------------- -- Expressions ----------------------------------------------------------- +-- | Create a named parameter with a default value. +namedParam :: Name -- ^ Name of the parameter. + -> Expr a -- ^ Default value for the parameter. + -> Expr a +namedParam n (Expr def) = Expr (ParamExpr (Just n) def) +-- | Create an anonymous parameter with a default value. +param :: Expr a -- ^ Default value. + -> Expr a +param (Expr def) = Expr (ParamExpr Nothing def) + unop :: UnOp -> Expr a -> Expr b unop op (Expr primExpr) = Expr (UnExpr op primExpr) @@ -282,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 @@ -318,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 @@ -368,7 +453,6 @@ numop :: Num a => BinOp -> Expr a -> Expr a -> Expr a numop = binop - -- | Addition (.+.) :: Num a => Expr a -> Expr a -> Expr a (.+.) = numop OpPlus @@ -403,15 +487,103 @@ -> 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 +-- it needs to be used in an expression context. The example below illustrates a +-- table with at least two fields, strField and bStrField. The first is defined as +-- containing strings, the second as containing strings up to 10 characters long. The +-- @toStr@ function must be used to convert the bStrField into the appropriate type for +-- projecting as the strField: +-- +-- > type SomeTable = (RecCons StrField (Expr String) +-- > (RecCons BStrField (Expr BStr10) ... )) +-- +-- > someTable :: Table SomeTable +-- > someTable = ... +-- +-- > strField :: Attr StrField String +-- > strField = ... +-- > +-- > bstrField :: Attr BStrField (BStr10) +-- > bstrField = ... +-- > +-- > query = do +-- > t <- table someTable +-- > project $ strField << toStr $ t ! bstrField +-- +class BStrToStr s d where + -- | Convert a bounded string to a real string. + toStr :: s -> d +instance (Size n) => BStrToStr (Expr (BoundedString n)) (Expr String) where + toStr (Expr e) = (Expr e) + +instance (Size n) => BStrToStr (Expr (Maybe (BoundedString n))) (Expr (Maybe String)) where + 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. +----------------------------------------------------------- + +-- | Used to implement variable length arguments to @func@, below. +class Args a where + arg_ :: String -> [PrimExpr] -> a + +-- | Used to limit variable argument form of @func@ to only take @Expr@ types, +-- and ignore @ExprAggr@ types. +class IsExpr a + +instance (IsExpr tail) => IsExpr (Expr a -> tail) + +instance IsExpr (Expr a) + +instance (IsExpr tail, Args tail) => Args (Expr a -> tail) where + arg_ name exprs = \(Expr prim) -> arg_ name (prim : exprs) + +instance Args (Expr a) where + -- Reverse necessary because arguments are built in reverse order by instances + -- of Args above. + arg_ name exprs = Expr (FunExpr name (reverse exprs)) + +instance Args (Expr a -> ExprAggr c) where + arg_ name exprs = \(Expr prim) -> ExprAggr (AggrExpr (AggrOther name) prim) + +{- | Can be used to define SQL functions which will +appear in queries. Each argument for the function is specified by its own Expr value. +Examples include: + +> lower :: Expr a -> Expr (Maybe String) +> lower str = func "lower" str + +The arguments to the function do not have to be Expr if they can +be converted to Expr: + +> data DatePart = Day | Century deriving Show + +> datePart :: DatePart -> Expr (Maybe CalendarTime) -> Expr (Maybe Int) +> datePart date col = func "date_part" (constant $ show date) col + +Aggregate functions can also be defined. For example: + + > every :: Expr Bool -> ExprAggr Bool + > every col = func "every" col + +Aggregates are implemented to always take one argument, so any attempt to +define an aggregate with any more or less arguments will result in an error. + +Note that type signatures are usually required for each function defined, +unless the arguments can be inferred.-} +func :: (Args a) => String -> a +func name = arg_ name [] + +----------------------------------------------------------- -- Default values ----------------------------------------------------------- @@ -454,11 +626,56 @@ constant :: ShowConstant a => a -> Expr a constant x = Expr (ConstExpr (showConstant x)) +-- | Inserts the string literally - no escaping, no quoting. +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) + +-- | Generates a 'CAST' expression for the given +-- expression, using the argument given as the destination +-- type. +cast :: String -- ^ Destination type. + -> Expr a -- ^ Source expression. + -> Expr b +cast typ (Expr expr) = Expr (CastExpr typ expr) + +-- | Coerce the type of an expression +-- to another type. Does not affect the actual +-- primitive value - only the `phantom' type. +coerce :: Expr a -- ^ Source expression + -> 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 @@ -468,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) + 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) @@ -553,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 ----------------------------------------------------------- @@ -566,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. @@ -584,6 +773,9 @@ -- Query Monad ----------------------------------------------------------- +unQuery :: Query a -> a +unQuery (Query g) = fst $ g (1, Empty) + runQuery :: Query (Rel r) -> PrimQuery runQuery = fst . runQueryRel @@ -593,7 +785,24 @@ assoc = zip scheme (map (AttrExpr . fresh alias) scheme) in (Project assoc primQuery, Rel 0 scheme) - +-- | Allows a subquery to be created between another query and +-- this query. Normally query definition is associative and query definition +-- is interleaved. This combinator ensures the given query is +-- added as a whole piece. +subQuery :: Query (Rel r) -> Query (Rel r) +subQuery (Query qs) = Query make + where + make (currentAlias, currentQry) = + -- Take the query to add and run it first, using the current alias as + -- a seed. + let (Rel otherAlias otherScheme,(newestAlias, otherQuery)) = qs (currentAlias,Empty) + -- Effectively renames all columns in otherQuery to make them unique in this + -- query. + assoc = zip (map (fresh newestAlias) otherScheme) + (map (AttrExpr . fresh otherAlias) otherScheme) + -- Produce a query which is a cross product of the other query and the current query. + in (Rel newestAlias otherScheme, (newestAlias + 1, times (Project assoc otherQuery) currentQry)) + instance Functor Query where fmap f (Query g) = Query (\q0 -> let (x,q1) = g q0 in (f x,q1)) @@ -603,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))) @@ -612,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 @@ -630,17 +842,8 @@ toPrimExprs :: r -> [PrimExpr] instance ToPrimExprs RecNil where - toPrimExprs RecNil = [] + toPrimExprs ~RecNil = [] instance (ExprC e, ToPrimExprs r) => ToPrimExprs (RecCons l (e a) r) where - toPrimExprs (RecCons e r) = primExpr e : toPrimExprs r - -{- + 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 @@ -15,6 +15,7 @@ module Database.HaskellDB.Sql ( SqlTable, SqlColumn, + SqlName, SqlOrder(..), SqlType(..), @@ -26,8 +27,9 @@ SqlDrop(..), SqlExpr(..), + Mark(..), - newSelect + newSelect, foldSqlExpr, foldSqlSelect ) where @@ -39,36 +41,104 @@ type SqlColumn = String +-- | A valid SQL name for a parameter. +type SqlName = String + data SqlOrder = SqlAsc | SqlDesc + deriving Show data SqlType = SqlType String | SqlType1 String Int | 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 :: [SqlExpr], -- ^ GROUP BY + groupby :: Maybe Mark, -- ^ GROUP BY orderby :: [(SqlExpr,SqlOrder)], -- ^ ORDER BY extra :: [String] -- ^ TOP n, etc. } | SqlBin String SqlSelect SqlSelect -- ^ Binary relational operator | 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] + | ExistsSqlExpr SqlSelect + | ParamSqlExpr (Maybe SqlName) SqlExpr + | PlaceHolderSqlExpr + | ParensSqlExpr SqlExpr + | 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] @@ -89,12 +159,12 @@ newSelect :: SqlSelect newSelect = SqlSelect { - options = ["DISTINCT"], - attrs = [], - tables = [], - criteria = [], - groupby = [], - orderby = [], - extra = [] + options = [], + attrs = [], + tables = [], + criteria = [], + 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 @@ -31,11 +31,13 @@ defaultSqlProject, defaultSqlRestrict, defaultSqlBinary, + defaultSqlGroup, defaultSqlSpecial, defaultSqlExpr, defaultSqlLiteral, defaultSqlType, + defaultSqlQuote, -- * Utilities toSqlSelect @@ -49,6 +51,9 @@ import System.Locale 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 @@ -68,11 +73,13 @@ sqlProject = defaultSqlProject gen, sqlRestrict = defaultSqlRestrict gen, sqlBinary = defaultSqlBinary gen, + sqlGroup = defaultSqlGroup gen, sqlSpecial = defaultSqlSpecial gen, sqlExpr = defaultSqlExpr gen, sqlLiteral = defaultSqlLiteral gen, - sqlType = defaultSqlType gen + sqlType = defaultSqlType gen, + sqlQuote = defaultSqlQuote gen } defaultSqlGenerator :: SqlGenerator @@ -90,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 ----------------------------------------------------------- @@ -100,12 +108,13 @@ -- | Creates a 'SqlSelect' based on the 'PrimQuery' supplied. -- Corresponds to the SQL statement SELECT. defaultSqlQuery :: SqlGenerator -> PrimQuery -> SqlSelect -defaultSqlQuery gen = foldPrimQuery (sqlEmpty gen, +defaultSqlQuery gen query = foldPrimQuery (sqlEmpty gen, sqlTable gen, sqlProject gen, sqlRestrict gen, sqlBinary gen, - sqlSpecial gen) + sqlGroup gen, + sqlSpecial gen) query defaultSqlEmpty :: SqlGenerator -> SqlSelect defaultSqlEmpty _ = SqlEmpty @@ -115,20 +124,115 @@ defaultSqlProject :: SqlGenerator -> Assoc -> SqlSelect -> SqlSelect defaultSqlProject gen assoc q - | hasAggr = select { groupby = map (sqlExpr gen) nonAggrs } - | otherwise = select - where - select = sql { attrs = toSqlAssoc gen assoc } - sql = toSqlSelect q + -- 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) - hasAggr = any isAggregate exprs - - -- TODO: we should make sure that every non-aggregate - -- is only a simple attribute expression - nonAggrs = filter (not.isAggregate) exprs - - exprs = map snd assoc + 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 } @@ -136,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 @@ -161,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) @@ -169,19 +277,48 @@ OpAsc -> SqlAsc OpDesc -> SqlDesc +-- | Make sure our SqlSelect statement is really a SqlSelect and not +-- another constructor. toSqlSelect :: SqlSelect -> SqlSelect toSqlSelect sql = case sql of - (SqlEmpty) -> newSelect - (SqlTable name) -> newSelect { tables = [("",sql)] } - (SqlBin op q1 q2) -> newSelect { tables = [("",sql)] } - s | null (attrs s) -> sql - | 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)] toSqlAssoc gen = map (\(attr,expr) -> (attr, sqlExpr gen expr)) toSqlOp :: RelOp -> String toSqlOp Union = "UNION" +toSqlOp UnionAll = "UNION ALL" toSqlOp Intersect = "INTERSECT" toSqlOp Divide = "DIVIDE" toSqlOp Difference = "EXCEPT" @@ -283,21 +420,48 @@ defaultSqlExpr gen e = case e of AttrExpr a -> ColumnSqlExpr a - BinExpr op e1 e2 -> BinSqlExpr (showBinOp op) (sqlExpr gen e1) (sqlExpr gen e2) + BinExpr op e1 e2 -> + let leftE = sqlExpr gen e1 + rightE = sqlExpr gen e2 + paren = ParensSqlExpr + (expL, expR) = case (op, e1, e2) of + (OpAnd, e1@(BinExpr OpOr _ _), e2@(BinExpr OpOr _ _)) -> + (paren leftE, paren rightE) + (OpOr, e1@(BinExpr OpAnd _ _), e2@(BinExpr OpAnd _ _)) -> + (paren leftE, paren rightE) + (OpAnd, e1@(BinExpr OpOr _ _), e2) -> + (paren leftE, rightE) + (OpAnd, e1, e2@(BinExpr OpOr _ _)) -> + (leftE, paren rightE) + (OpOr, e1@(BinExpr OpAnd _ _), e2) -> + (paren leftE, rightE) + (OpOr, e1, e2@(BinExpr OpAnd _ _)) -> + (leftE, paren 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 in CaseSqlExpr cs' e' ListExpr es -> ListSqlExpr (map (sqlExpr gen) es) + ParamExpr n v -> ParamSqlExpr n PlaceHolderSqlExpr + FunExpr n exprs -> FunSqlExpr n (map (sqlExpr gen) exprs) + CastExpr typ e1 -> CastSqlExpr typ (sqlExpr gen e1) showBinOp :: BinOp -> String showBinOp OpEq = "=" @@ -361,6 +525,9 @@ where fmt = iso8601DateFormat (Just "%H:%M:%S") OtherLit l -> l + +defaultSqlQuote :: SqlGenerator -> String -> String +defaultSqlQuote gen s = quote s -- | Quote a string and escape characters that need escaping -- FIXME: this is backend dependent diff --git a/src/Database/HaskellDB/Sql/Generate.hs b/src/Database/HaskellDB/Sql/Generate.hs --- a/src/Database/HaskellDB/Sql/Generate.hs +++ b/src/Database/HaskellDB/Sql/Generate.hs @@ -34,11 +34,17 @@ sqlEmpty :: SqlSelect, sqlTable :: TableName -> Scheme -> SqlSelect, sqlProject :: Assoc -> SqlSelect -> SqlSelect, + -- | Ensures non-aggregate expressions in the select are included in + -- group by clause. + sqlGroup :: Assoc -> SqlSelect -> SqlSelect, sqlRestrict :: PrimExpr -> SqlSelect -> SqlSelect, sqlBinary :: RelOp -> SqlSelect -> SqlSelect -> SqlSelect, sqlSpecial :: SpecialOp -> SqlSelect -> SqlSelect, sqlExpr :: PrimExpr -> SqlExpr, sqlLiteral :: Literal -> String, - sqlType :: FieldType -> SqlType + sqlType :: FieldType -> SqlType, + -- | Turn a string into a quoted string. Quote characters + -- and any escaping are handled by this function. + sqlQuote :: String -> String } diff --git a/src/Database/HaskellDB/Sql/MySQL.hs b/src/Database/HaskellDB/Sql/MySQL.hs --- a/src/Database/HaskellDB/Sql/MySQL.hs +++ b/src/Database/HaskellDB/Sql/MySQL.hs @@ -13,9 +13,28 @@ ----------------------------------------------------------- module Database.HaskellDB.Sql.MySQL (generator) where +import Database.HaskellDB.Sql import Database.HaskellDB.Sql.Default import Database.HaskellDB.Sql.Generate import Database.HaskellDB.PrimQuery generator :: SqlGenerator -generator = mkSqlGenerator generator +generator = (mkSqlGenerator generator) { + sqlBinary = mySqlBinary + } + +mySqlBinary :: RelOp -> SqlSelect -> SqlSelect -> SqlSelect +mySqlBinary Difference = mySqlDifference +mySqlBinary op = defaultSqlBinary generator op + +{- Hack around the lack of "EXCEPT" in MySql -} +mySqlDifference :: SqlSelect -> SqlSelect -> SqlSelect +mySqlDifference sel1 sel2 + = (toSqlSelect sel1) { criteria = [PrefixSqlExpr "NOT" $ ExistsSqlExpr existsSql] } + where existsSql = (toSqlSelect ((toSqlSelect sel2) { attrs = zipWith mkAttr names renames })) + { criteria = zipWith mkCond names renames } + names = map fst $ attrs sel2 -- attrs sel1 should be the same, but it turned out to + -- be undefined in the case I tried + renames = map (++"_local") names + mkAttr name rename = (rename, ColumnSqlExpr name) + mkCond name rename = BinSqlExpr "=" (ColumnSqlExpr name) (ColumnSqlExpr rename) 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 @@ -18,18 +18,33 @@ import Database.HaskellDB.Sql.Generate import Database.HaskellDB.FieldType import Database.HaskellDB.PrimQuery +import System.Locale +import System.Time generator :: SqlGenerator -generator = mkSqlGenerator generator - { - sqlSpecial = postgresqlSpecial, - sqlType = postgresqlType - } +generator = (mkSqlGenerator generator) { sqlSpecial = postgresqlSpecial + , sqlType = postgresqlType + , sqlLiteral = postgresqlLiteral + , sqlExpr = postgresqlExpr + } postgresqlSpecial :: SpecialOp -> SqlSelect -> SqlSelect postgresqlSpecial op q = defaultSqlSpecial generator op q +-- Postgres > 7.1 wants a timezone with calendar time. +postgresqlLiteral :: Literal -> String +postgresqlLiteral (DateLit d) = defaultSqlQuote generator (formatCalendarTime defaultTimeLocale fmt d) + where fmt = iso8601DateFormat (Just "%H:%M:%S %Z") +postgresqlLiteral l = defaultSqlLiteral generator l + postgresqlType :: FieldType -> SqlType postgresqlType BoolT = SqlType "boolean" postgresqlType t = defaultSqlType generator t + +postgresqlExpr :: PrimExpr -> SqlExpr +postgresqlExpr (BinExpr OpMod e1 e2) = + let e1S = defaultSqlExpr generator e1 + e2S = defaultSqlExpr generator e2 + in BinSqlExpr "%" e1S e2S +postgresqlExpr e = defaultSqlExpr generator e 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,12 +71,19 @@ ppWhere :: [SqlExpr] -> Doc ppWhere [] = empty ppWhere es = text "WHERE" - <+> hsep (intersperse (text "AND") (map ppSqlExpr es)) - -ppGroupBy :: [SqlExpr] -> Doc -ppGroupBy [] = empty -ppGroupBy es = text "GROUP BY" <+> commaV ppSqlExpr es + <+> hsep (intersperse (text "AND") + (map (parens . ppSqlExpr) 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 (_, ColumnSqlExpr col) = text col + nameOrExpr (_, expr) = parens (ppSqlExpr expr) + ppOrderBy :: [(SqlExpr,SqlOrder)] -> Doc ppOrderBy [] = empty ppOrderBy ord = text "ORDER BY" <+> commaV ppOrd ord @@ -138,8 +145,7 @@ ppF (fname,t) = text fname <+> ppSqlTypeNull t ppSqlTypeNull :: (SqlType,Bool) -> Doc -ppSqlTypeNull (t,nullable) = if nullable then t' else t' <+> text " not null" - where t' = ppSqlType t +ppSqlTypeNull (t,nullable) = ppSqlType t <+> text (if nullable then " null" else " not null") ppSqlType :: SqlType -> Doc ppSqlType (SqlType t) = text t @@ -162,16 +168,23 @@ ppSqlExpr e = case e of ColumnSqlExpr c -> text c - BinSqlExpr op e1 e2 -> ppSqlExpr e1 <+> text op <+> ppSqlExpr e2 + ParensSqlExpr e -> parens (ppSqlExpr e) + BinSqlExpr op e1 e2 -> ppSqlExpr e1 <+> text op <+> ppSqlExpr e2 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" where ppWhen (w,t) = text "WHEN" <+> ppSqlExpr w <+> text "THEN" <+> ppSqlExpr t ListSqlExpr es -> parens (commaH ppSqlExpr es) + ExistsSqlExpr s -> text "EXISTS" <+> parens (ppSql s) + ParamSqlExpr n v -> ppSqlExpr v + PlaceHolderSqlExpr -> text "?" + CastSqlExpr typ expr -> text "CAST" <> parens (ppSqlExpr expr <+> text "AS" <+> text typ) + commaH :: (a -> Doc) -> [a] -> Doc commaH f = hcat . punctuate comma . map f diff --git a/src/Database/HaskellDB/Sql/SQLite.hs b/src/Database/HaskellDB/Sql/SQLite.hs --- a/src/Database/HaskellDB/Sql/SQLite.hs +++ b/src/Database/HaskellDB/Sql/SQLite.hs @@ -19,7 +19,7 @@ import Database.HaskellDB.PrimQuery generator :: SqlGenerator -generator = mkSqlGenerator generator +generator = (mkSqlGenerator generator) { sqlLiteral = literal }