haskelldb 0.10 → 2.2.4

raw patch · 25 files changed

Files

• LICENSE +31/−0
• haskelldb.cabal +66/−37
• src/Database/HaskellDB.hs +88/−34
• src/Database/HaskellDB/BoundedList.hs +10/−2
• src/Database/HaskellDB/DBDirect.hs +152/−0
• src/Database/HaskellDB/DBLayout.hs +21/−18
• src/Database/HaskellDB/DBSpec/DBInfo.hs +34/−18
• src/Database/HaskellDB/DBSpec/DBSpecToDBDirect.hs +86/−68
• src/Database/HaskellDB/DBSpec/DatabaseToDBSpec.hs +9/−4
• src/Database/HaskellDB/DBSpec/PPHelpers.hs +60/−18
• src/Database/HaskellDB/Database.hs +39/−22
• src/Database/HaskellDB/DriverAPI.hs +22/−2
• src/Database/HaskellDB/FieldType.hs +94/−5
• src/Database/HaskellDB/HDBRec.hs +23/−14
• src/Database/HaskellDB/Optimize.hs +83/−61
• src/Database/HaskellDB/PrimQuery.hs +45/−11
• src/Database/HaskellDB/PrintQuery.hs +145/−0
• src/Database/HaskellDB/Query.hs +324/−121
• src/Database/HaskellDB/Sql.hs +79/−9
• src/Database/HaskellDB/Sql/Default.hs +192/−25
• src/Database/HaskellDB/Sql/Generate.hs +7/−1
• src/Database/HaskellDB/Sql/MySQL.hs +20/−1
• src/Database/HaskellDB/Sql/PostgreSQL.hs +20/−5
• src/Database/HaskellDB/Sql/Print.hs +22/−9
• src/Database/HaskellDB/Sql/SQLite.hs +1/−1

@@ -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.

@@ -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" <jgbailey@gmail.com>+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

@@ -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" <jgbailey@gmail.com> -- 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 _ = []

@@ -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.

@@ -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")+       "<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] <module> <db-name> <driver-options>\n"+          footer = unlines $+             "" :+             "NOTE: You will probably have to specify the db name in both <driver-options> and <db-name>.  This is because the driver options are specific to each database." :+             "" :+             "module:          Module name without an extension" :+             ("driver-options:  " +++                (concat . intersperse "," .+                 map (\(name,descr) -> name++"=<"++descr++">") .+                 requiredOptions) driver) :+             []+      hPutStrLn stderr $ (usageInfo header options ++ footer)

@@ -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

@@ -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]

@@ -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)

@@ -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

@@ -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?

@@ -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

@@ -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"

@@ -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

@@ -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)

@@ -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

@@ -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)

@@ -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

@@ -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 ""))--}

@@ -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     = []                       } 

@@ -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

@@ -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     }

@@ -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)

@@ -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

@@ -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

@@ -19,7 +19,7 @@ import Database.HaskellDB.PrimQuery  generator :: SqlGenerator-generator = mkSqlGenerator generator +generator = (mkSqlGenerator generator)             {              sqlLiteral = literal             }