Permalink
Browse files

Bug fixes and expanded query capabilities

Ignore-this: 9e4e3a03c4684fd1dc7c732fe934be50

A major update to query capabilities and fixed long-broken tests
against postgres. From the changelog:

	* Added support for arbitrary sql functions in Database.HaskellDB.Query
	* Added support for cast and coerce SQL functions in queries.
	* Added support for anonymous and named parameters.
	* Bug fixes around aggregate expressions.
	* Updated Postgres SQL generation module so timestamp columns WITH timezone are created
	  when the column type in the table is CalendarTimeT.
	* Updated Postgres SQL generation so CalendarTime values include timezone information
	when they are sent to the database.
	* Removed picoseconds from CalendarTime values in TestCases.hs.
	* Added sqlQuote and defaulSqlQuote to SQL generation so quoting and escaping can be
	overridden on a per-database basis.
	* Updated Tests/test-hdbc-postgres.hs to take arguments.
	* Associativity fixes between AND and OR operators in SQL queries.
	* Got test/TestCases.hs working against postgres database.
	* Rolled version to 0.13

darcs-hash:20090409211005-447ee-6c442f0e6872c069575f32d1434a0ae7020302f7.gz
  • Loading branch information...
1 parent 97d1e73 commit 40c52e32a6bb4e30aecf744643948dc2f768086c @m4dc4p committed Apr 9, 2009
View
@@ -1,3 +1,19 @@
+2009-04-09 jgbailey@gmail.com
+ * Added support for arbitrary sql functions in Database.HaskellDB.Query
+ * Added support for cast and coerce SQL functions in queries.
+ * Added support for anonymous and named parameters.
+ * Bug fixes around aggregate expressions.
+ * Updated Postgres SQL generation module so timestamp columns WITH timezone are created
+ when the column type in the table is CalendarTimeT.
+ * Updated Postgres SQL generation so CalendarTime values include timezone information
+ when they are sent to the database.
+ * Removed picoseconds from CalendarTime values in TestCases.hs.
+ * Added sqlQuote and defaulSqlQuote to SQL generation so quoting and escaping can be
+ overridden on a per-database basis.
+ * Updated Tests/test-hdbc-postgres.hs to take arguments.
+ * Associativity fixes between AND and OR operators in SQL queries.
+ * Got test/TestCases.hs working against postgres database.
+ * Rolled version to 0.13
2009-02-13 jgbailey@gmail.com
* Updated HDBC support to v2.0 (thanks to Artyom Shalkhakov <artyom.shalkhakov@gmail.com>).
* Fixed HDBC-odbc connection string handling to use semi colons instead of spaces.
View
@@ -1,10 +1,10 @@
Name: haskelldb
-Version: 0.12
+Version: 0.13
Cabal-version: >= 1.2
Build-type: Simple
Homepage: http://haskelldb.sourceforge.net
Copyright: The authors
-Maintainer: haskelldb-users@lists.sourceforge.net
+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
License: BSD3
Synopsis: SQL unwrapper for Haskell.
@@ -25,7 +25,7 @@ import Database.HaskellDB.PrimQuery
optimize :: PrimQuery -> PrimQuery
optimize = hacks
. mergeProject
- . removeEmpty
+ . removeEmpty
. removeDead
. pushRestrict
. optimizeExprs
@@ -123,7 +123,7 @@ removeD live (Special (Order xs) query)
-- live columns are NOT just those that are in the select, but also those
-- used in restrictions.
removeD live (Group cols query)
- = Group liveCols (removeD (live ++ (map fst liveCols)) query)
+ = Group cols (removeD live query)
where
liveCols = filter ((`elem` live) . fst) cols
@@ -133,7 +133,7 @@ removeD live query
-- | Remove unused parts of the query
removeEmpty :: PrimQuery -> PrimQuery
-removeEmpty
+removeEmpty
= foldPrimQuery (Empty, BaseTable, project, restrict, binary, group, special)
where
-- Messes up queries without a table, e.g. constant queries
@@ -158,11 +158,10 @@ removeEmpty
group _ Empty = Empty
group cols query = Group cols query
-
-- | Collapse adjacent projections
mergeProject :: PrimQuery -> PrimQuery
-mergeProject
- = foldPrimQuery (Empty,BaseTable,project,Restrict,Binary,Group, Special)
+mergeProject q
+ = foldPrimQuery (Empty,BaseTable,project,Restrict,Binary,Group, Special) q
where
project assoc1 (Project assoc2 query)
| safe newAssoc = Project newAssoc query
@@ -194,7 +193,7 @@ mergeProject
safe :: Assoc -> Bool
safe assoc
- = not (any (isAggregate.snd) assoc)
+ = not (any (isAggregate.snd) assoc) || all (isAggregate . snd) assoc
-- | Push restrictions down through projections and binary ops.
pushRestrict :: PrimQuery -> PrimQuery
@@ -278,7 +277,7 @@ optimizeExprs = foldPrimQuery (Empty, BaseTable, Project, restr, Binary, Group,
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 @@ module Database.HaskellDB.PrimQuery (
-- * Type Declarations
-- ** Types
- TableName, Attribute, Scheme, Assoc
+ TableName, Attribute, Scheme, Assoc, Name
-- ** Data types
, PrimQuery(..), RelOp(..), SpecialOp(..)
@@ -30,7 +30,7 @@ module Database.HaskellDB.PrimQuery (
, extend, times
, attributes, attrInExpr, attrInOrder
, substAttr
- , isAggregate
+ , isAggregate, isConstant
, foldPrimQuery, foldPrimExpr
) where
@@ -49,6 +49,7 @@ import Text.PrettyPrint.HughesPJ
type TableName = String
type Attribute = String
+type Name = String
type Scheme = [Attribute]
type Assoc = [(Attribute,PrimExpr)]
@@ -86,6 +87,9 @@ data PrimExpr = AttrExpr Attribute
| 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
@@ -166,15 +170,18 @@ assocFromScheme scheme
-- | 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
@@ -183,24 +190,38 @@ attrInOrder os = concat [attrInExpr e | OrderExpr _ e <- os]
-- | 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 = countConstant x > 0
+ where
+ countConstant = foldPrimExpr (const 0, const 1, binary, unary, aggr, const2 0, const 0,const2 0, const2 0, cast)
+ where
+ const2 a _ _ = a
+ binary op x y = if x == 0 || y == 0 then 0 else 1
+ unary op x = x
+ aggr op 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,
@@ -225,8 +246,8 @@ foldPrimQuery (empty,table,project,restrict,binary,group,special)
-- | 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
@@ -236,5 +257,8 @@ foldPrimExpr (attr,scalar,binary,unary,aggr,_case,list)
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)
Oops, something went wrong.

0 comments on commit 40c52e3

Please sign in to comment.