diff --git a/haskelldb.cabal b/haskelldb.cabal --- a/haskelldb.cabal +++ b/haskelldb.cabal @@ -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" 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. @@ -12,11 +12,11 @@ Flag split-base Library - Build-depends: mtl + Build-depends: mtl >= 1 && < 2 if flag(split-base) - Build-depends: base >= 3.0, pretty, old-time, old-locale, directory + Build-depends: base >= 3 && < 5, pretty >= 1 && < 2, old-time >= 1 && < 2, old-locale >= 1 && < 2, directory >= 1 && < 2 else - Build-depends: base < 3.0 + Build-depends: base < 3 Extensions: ExistentialQuantification, OverlappingInstances, @@ -44,6 +44,7 @@ Database.HaskellDB.HDBRec, Database.HaskellDB.Optimize, Database.HaskellDB.PrimQuery, + Database.HaskellDB.PrintQuery, Database.HaskellDB.Query, Database.HaskellDB.Sql, Database.HaskellDB.Sql.Generate, diff --git a/src/Database/HaskellDB.hs b/src/Database/HaskellDB.hs --- a/src/Database/HaskellDB.hs +++ b/src/Database/HaskellDB.hs @@ -5,7 +5,7 @@ -- HWT Group (c) 2003, haskelldb-users@lists.sourceforge.net -- License : BSD-style -- --- Maintainer : haskelldb-users@lists.sourceforge.net +-- Maintainer : "Justin Bailey" -- Stability : experimental -- Portability : non portable -- @@ -39,7 +39,7 @@ -- ----------------------------------------------------------- module Database.HaskellDB - ( Rel, Attr, Expr, Table, Query, OrderExpr + ( Rel, Attr, Expr, ExprAggr, Table, Query, OrderExpr -- * Records , HasField, Record, Select, ( # ), ( << ), (<<-), (!), (!.) @@ -55,6 +55,8 @@ , _not, like, _in, cat, _length , isNull, notNull, fromNull , constant, constJust + , param, namedParam, Args, func + , queryParams, Param , count, _sum, _max, _min, avg , stddev, stddevP, variance, varianceP @@ -78,6 +80,8 @@ import Database.HaskellDB.HDBRec -- PrimQuery type is imported so that haddock can find it. import Database.HaskellDB.PrimQuery (PrimQuery) +import Database.HaskellDB.Sql (SqlSelect(SqlSelect, SqlBin), SqlExpr(..), SqlName) +import qualified Database.HaskellDB.Sql as S (SqlSelect(..)) import Database.HaskellDB.Sql.Generate (sqlQuery) import Database.HaskellDB.Sql.Default (defaultSqlGenerator) import Database.HaskellDB.Sql.Print (ppSql) @@ -85,7 +89,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 +113,48 @@ -- | 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 = getParams (exprParams . snd) + 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 (CaseSqlExpr es e) = + let caseExprs = concatMap (\(l, r) -> exprParams l ++ exprParams r) es + in caseExprs ++ exprParams e + exprParams (ListSqlExpr es) = concatMap exprParams es + exprParams (ExistsSqlExpr select) = selectParams select + exprParams PlaceHolderSqlExpr = [] + exprParams (ParensSqlExpr e) = exprParams e + exprParams (CastSqlExpr _ e) = exprParams e + selectParams (SqlBin _ l r) = selectParams l ++ selectParams r + selectParams _ = [] diff --git a/src/Database/HaskellDB/Optimize.hs b/src/Database/HaskellDB/Optimize.hs --- a/src/Database/HaskellDB/Optimize.hs +++ b/src/Database/HaskellDB/Optimize.hs @@ -25,7 +25,7 @@ optimize :: PrimQuery -> PrimQuery optimize = hacks . mergeProject - . removeEmpty + . removeEmpty . removeDead . pushRestrict . optimizeExprs @@ -123,7 +123,7 @@ -- 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,13 +133,13 @@ -- | 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 -- 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 @@ -158,11 +158,10 @@ 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 @@ 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 @@ where e' = optimizeExpr e optimizeExpr :: PrimExpr -> PrimExpr -optimizeExpr = foldPrimExpr (AttrExpr,ConstExpr,bin,un,AggrExpr,CaseExpr,ListExpr) +optimizeExpr = foldPrimExpr (AttrExpr,ConstExpr,bin,un,AggrExpr,CaseExpr,ListExpr,ParamExpr,FunExpr, CastExpr) where bin OpAnd e1 e2 | exprIsFalse e1 || exprIsFalse e2 = exprFalse diff --git a/src/Database/HaskellDB/PrimQuery.hs b/src/Database/HaskellDB/PrimQuery.hs --- a/src/Database/HaskellDB/PrimQuery.hs +++ b/src/Database/HaskellDB/PrimQuery.hs @@ -18,7 +18,7 @@ -- * Type Declarations -- ** Types - TableName, Attribute, Scheme, Assoc + TableName, Attribute, Scheme, Assoc, Name -- ** Data types , PrimQuery(..), RelOp(..), SpecialOp(..) @@ -30,7 +30,7 @@ , extend, times , attributes, attrInExpr, attrInOrder , substAttr - , isAggregate + , isAggregate, isConstant , foldPrimQuery, foldPrimExpr ) where @@ -49,6 +49,7 @@ type TableName = String type Attribute = String +type Name = String type Scheme = [Attribute] type Assoc = [(Attribute,PrimExpr)] @@ -86,6 +87,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 @@ -166,15 +170,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 @@ -183,24 +190,38 @@ -- | 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 @@ -- | 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 @@ fold (AggrExpr op x) = aggr op (fold x) fold (CaseExpr cs el) = _case (map (both fold) cs) (fold el) fold (ListExpr xs) = list (map fold xs) + fold (ParamExpr n value) = param n (fold value) + fold (FunExpr n exprs) = fun n (map fold exprs) + fold (CastExpr n expr) = cast n (fold expr) both f (x,y) = (f x, f y) diff --git a/src/Database/HaskellDB/PrintQuery.hs b/src/Database/HaskellDB/PrintQuery.hs new file mode 100644 --- /dev/null +++ b/src/Database/HaskellDB/PrintQuery.hs @@ -0,0 +1,131 @@ +----------------------------------------------------------- +-- | +-- Module : PrintQuery.hs +-- Copyright : haskelldb-users@lists.sourceforge.net +-- License : BSD-style +-- +-- Maintainer : haskelldb-users@lists.sourceforge.net +-- Stability : experimental +-- Portability : non portable +-- Author : Justin Bailey (jgbailey AT gmail DOT com) +-- Pretty printing for Query, PrimQuery, and SqlSelect values. +-- Useful for debugging the library. +-- +----------------------------------------------------------- +module Database.HaskellDB.PrintQuery (ppQuery, ppQueryUnOpt + , ppSelect, ppSelectUnOpt, ppSqlSelect, ppPrim) + +where + +import Database.HaskellDB.PrimQuery +import Database.HaskellDB.Sql +import Database.HaskellDB.Query (Query, runQuery, Rel) +import Database.HaskellDB.Optimize (optimize) +import Database.HaskellDB.Sql.Generate (sqlQuery) +import Database.HaskellDB.Sql.Default (defaultSqlGenerator) +import Text.PrettyPrint.HughesPJ + +-- | Take a query, turn it into a SqlS +ppSelect :: Query (Rel r) -> Doc +ppSelect qry = ppPQ (sqlQuery defaultSqlGenerator) optimize (runQuery $ qry) + +-- | Take a query, turn it into a SqlS +ppSelectUnOpt :: Query (Rel r) -> Doc +ppSelectUnOpt qry = ppPQ (sqlQuery defaultSqlGenerator) id (runQuery $ qry) + +-- | Optimize the query and pretty print it. +ppQuery :: Query (Rel r) -> Doc +ppQuery qry = ppPrimF optimize (runQuery $ qry) + +-- | Pretty print an unoptimized query. +ppQueryUnOpt :: Query (Rel r) -> Doc +ppQueryUnOpt qry = ppPrimF id (runQuery $ qry) + +-- | Pretty print a PrimQuery value. +ppPrim :: PrimQuery -> Doc +ppPrim = ppPrimF id + +-- | Transform a PrimQuery according to the function given, then +-- pretty print it. +ppPrimF :: (PrimQuery -> PrimQuery) -- ^ Transformation function to apply to PrimQuery first. + -> PrimQuery -- ^ PrimQuery to print. + -> Doc +ppPrimF f qry = ppPrimF' (f qry) + where + ppPrimF' (BaseTable tableName scheme) = + hang (text "BaseTable" <> colon <+> text tableName) + nesting + (brackets (fsep $ punctuate comma (map text scheme))) + ppPrimF' (Project assoc primQuery) = + hang (text "Project") + nesting (brackets (ppAssoc assoc) $+$ + parens (ppPrimF' primQuery)) + ppPrimF' (Restrict primExpr primQuery) = + hang (text "Restrict") + nesting + (ppExpr primExpr $+$ ppPrimF' primQuery) + ppPrimF' (Group assoc primQuery) = + hang (text "Group") + nesting + (brackets (ppAssoc assoc) $+$ + parens (ppPrimF' primQuery)) + ppPrimF' (Binary relOp primQueryL primQueryR) = + hang (text "Binary:" <+> text (show relOp)) + nesting + (parens (ppPrimF' primQueryL) $+$ + parens (ppPrimF' primQueryR)) + ppPrimF' (Special specialOp primQuery) = + hang (text "Special:" <+> text (show specialOp)) + nesting + (parens (ppPrimF' primQuery)) + ppPrimF' Empty = text "Empty" + + -- | Pretty print an Assoc list (i.e. columns and expression). + ppAssoc :: Assoc -> Doc + ppAssoc assoc = fsep . punctuate comma . map (\(a, e) -> text a <> colon <+> ppExpr e) $ assoc + + -- | Pretty print an PrimExpr value. + ppExpr :: PrimExpr -> Doc + ppExpr = text . show + +ppPQ :: (PrimQuery -> SqlSelect) -- ^ Function to turn primitive query into a SqlSelect. + -> (PrimQuery -> PrimQuery) -- ^ Transformation to apply to query, if any. + -> PrimQuery -- ^ The primitive query to transform and print. + -> Doc +ppPQ select trans prim = ppSqlSelect . select . trans $ prim + +ppSqlSelect :: SqlSelect -> Doc +ppSqlSelect (SqlBin string sqlSelectL sqlSelectR) = + hang (text "SqlBin:" <+> text string) nesting + (parens (ppSqlSelect sqlSelectL) $+$ + parens (ppSqlSelect sqlSelectR)) +ppSqlSelect (SqlTable sqlTable) = text "SqlTable:" <+> text sqlTable +ppSqlSelect SqlEmpty = text "SqlEmpty" +ppSqlSelect (SqlSelect options attrs tables criteria groupby orderby extra) = + hang (text "SqlSelect") nesting $ + hang (text "attrs:") nesting (brackets . fsep . punctuate comma . map ppAttr $ attrs) $+$ + text "criteria:" <+> (brackets . fsep . punctuate comma . map ppSqlExpr $ criteria) $+$ + hang (text "tables:") nesting (brackets . fsep . punctuate comma . map ppTable $ tables) $+$ + hang (text "groupby:") nesting (brackets . fsep . punctuate comma . map ppAttr $ groupby) $+$ + hang (text "orderby:") nesting (brackets . fsep . punctuate comma . map ppOrder $ orderby) $+$ + text "extras:" <+> (brackets . fsep. punctuate comma . map text $ extra) $+$ + text "options:" <+> (brackets . fsep . punctuate comma . map text $ options) + +ppTable :: (SqlTable, SqlSelect) -> Doc +ppTable (tbl, select) = + if null tbl + then ppSqlSelect select + else hang (text tbl <> colon) nesting (ppSqlSelect select) + +ppAttr :: (SqlColumn, SqlExpr) -> Doc +ppAttr (col, expr) = text col <> colon <+> ppSqlExpr expr + +ppOrder :: (SqlExpr, SqlOrder) -> Doc +ppOrder (expr, order) = parens (ppSqlExpr expr) <+> text (show order) + +ppSqlExpr :: SqlExpr -> Doc +ppSqlExpr sql = text $ show sql + +-- | Nesting level. +nesting :: Int +nesting = 2 diff --git a/src/Database/HaskellDB/Query.hs b/src/Database/HaskellDB/Query.hs --- a/src/Database/HaskellDB/Query.hs +++ b/src/Database/HaskellDB/Query.hs @@ -17,7 +17,7 @@ ----------------------------------------------------------- module Database.HaskellDB.Query ( -- * Data and class declarations - Rel(..), Attr(..), Table(..), Query, Expr(..), OrderExpr + Rel(..), Attr(..), Table(..), Query, Expr(..), ExprAggr, OrderExpr , ToPrimExprs, ShowConstant , ExprC, ProjectExpr, ProjectRec, InsertRec , ConstantRecord(..) @@ -26,6 +26,7 @@ , (.&&.) , (.||.) , (.*.) , (./.), (.%.), (.+.), (.-.), (.++.) , (<<), (<<-) + , recAttr -- * Function declarations , project, restrict, table, unique , union, intersect, divide, minus @@ -33,7 +34,11 @@ , isNull, notNull , fromNull , constant, constJust + , param, namedParam, Args, func, constNull, cast + , toStr, coerce + , select , count, _sum, _max, _min, avg + , literal , stddev, stddevP, variance, varianceP , asc, desc, order , top --, topPercent @@ -41,6 +46,7 @@ , _default -- * Internals , runQuery, runQueryRel + , subQuery , attribute, tableName, baseTable , attributeName, exprs, labels ) where @@ -166,6 +172,15 @@ -> Record (RecCons f (Expr a) RecNil) -- ^ New record f <<- x = f << constant x +-- | Creates a single-field record from an attribute and a table. Useful +-- for building projections that will re-use the same attribute name. @recAttr attr tbl@ is +-- equivalent to: +-- +-- @attr << tbl ! attr@ +-- +recAttr :: (HasField f r) => Attr f a -> Rel r -> Record (RecCons f (Expr a) RecNil) +recAttr attr tbl = attr << tbl ! attr + ----------------------------------------------------------- -- Basic relational operators ----------------------------------------------------------- @@ -200,28 +215,34 @@ restrict (Expr primExpr) = updatePrimQuery_ (Restrict primExpr) -- | Restricts the relation given to only return unique records. Upshot --- is all projected attributes will be 'grouped' +-- 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 findNonAggr primQ of + 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. - findNonAggr :: PrimQuery -> Assoc - findNonAggr (Project cols q) = filter (not . isAggregate . snd) cols - findNonAggr (Restrict _ q) = findNonAggr q - findNonAggr (Binary _ q1 q2) = findNonAggr q1 ++ findNonAggr q2 - findNonAggr (BaseTable tblName cols) = zip cols (map AttrExpr cols) - findNonAggr (Special _ q) = findNonAggr q + -- 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 - findNonAggr (Group _ _) = [] - findNonAggr Empty = [] - + projected (Group _ _) = [] + projected Empty = [] + + ----------------------------------------------------------- -- Binary operations ----------------------------------------------------------- @@ -230,9 +251,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) @@ -244,7 +264,7 @@ 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. @@ -292,11 +312,20 @@ 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) @@ -391,7 +420,6 @@ numop :: Num a => BinOp -> Expr a -> Expr a -> Expr a numop = binop - -- | Addition (.+.) :: Num a => Expr a -> Expr a -> Expr a (.+.) = numop OpPlus @@ -434,7 +462,98 @@ -> 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 + + ----------------------------------------------------------- +-- 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 ----------------------------------------------------------- @@ -472,16 +591,38 @@ instance Size n => ShowConstant (BoundedString n) where showConstant = showConstant . fromBounded - -- | Creates a constant expression from a haskell value. constant :: ShowConstant a => a -> Expr a constant x = Expr (ConstExpr (showConstant x)) +-- | Inserts the string literally - no escaping, no quoting. +literal :: String -> Expr a +literal x = Expr (ConstExpr (OtherLit x)) + -- | Turn constant data into a nullable expression. -- Same as @constant . Just@ constJust :: ShowConstant a => a -> Expr (Maybe a) constJust 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 + class ConstantRecord r cr | r -> cr where constantRecord :: r -> cr @@ -616,7 +757,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)) diff --git a/src/Database/HaskellDB/Sql.hs b/src/Database/HaskellDB/Sql.hs --- a/src/Database/HaskellDB/Sql.hs +++ b/src/Database/HaskellDB/Sql.hs @@ -15,6 +15,7 @@ module Database.HaskellDB.Sql ( SqlTable, SqlColumn, + SqlName, SqlOrder(..), SqlType(..), @@ -39,6 +40,9 @@ type SqlColumn = String +-- | A valid SQL name for a parameter. +type SqlName = String + data SqlOrder = SqlAsc | SqlDesc deriving Show @@ -72,6 +76,10 @@ | CaseSqlExpr [(SqlExpr,SqlExpr)] SqlExpr | ListSqlExpr [SqlExpr] | ExistsSqlExpr SqlSelect + | ParamSqlExpr (Maybe SqlName) SqlExpr + | PlaceHolderSqlExpr + | ParensSqlExpr SqlExpr + | CastSqlExpr String SqlExpr deriving Show -- | Data type for SQL UPDATE statements. diff --git a/src/Database/HaskellDB/Sql/Default.hs b/src/Database/HaskellDB/Sql/Default.hs --- a/src/Database/HaskellDB/Sql/Default.hs +++ b/src/Database/HaskellDB/Sql/Default.hs @@ -37,6 +37,7 @@ defaultSqlExpr, defaultSqlLiteral, defaultSqlType, + defaultSqlQuote, -- * Utilities toSqlSelect @@ -50,6 +51,8 @@ import System.Locale import System.Time +import Data.Maybe (catMaybes) +import Data.List (nubBy) mkSqlGenerator :: SqlGenerator -> SqlGenerator mkSqlGenerator gen = SqlGenerator @@ -74,7 +77,8 @@ sqlExpr = defaultSqlExpr gen, sqlLiteral = defaultSqlLiteral gen, - sqlType = defaultSqlType gen + sqlType = defaultSqlType gen, + sqlQuote = defaultSqlQuote gen } defaultSqlGenerator :: SqlGenerator @@ -102,13 +106,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, sqlGroup gen, - sqlSpecial gen) + sqlSpecial gen) query defaultSqlEmpty :: SqlGenerator -> SqlSelect defaultSqlEmpty _ = SqlEmpty @@ -118,21 +122,55 @@ defaultSqlProject :: SqlGenerator -> Assoc -> SqlSelect -> SqlSelect defaultSqlProject gen assoc q - | hasAggr = select { groupby = toSqlAssoc gen nonAggrs } + | hasAggr = select { groupby = toSqlAssoc gen groupableProjections ++ groupableOrderCols } | otherwise = select where select = sql { attrs = toSqlAssoc gen assoc } sql = toSqlSelect q hasAggr = (not . null . filter (isAggregate . snd)) assoc - nonAggrs = filter (not . isAggregate . snd) assoc - + -- Find projected columns that are not constants or aggregates. + groupableProjections = filter (not . (\x -> isAggregate x || isConstant x) . snd) assoc + -- Get list of order by columns which do not appear in + -- projected non-aggregate columns already, if any. + groupableOrderCols = + let eligible = filter (\x -> case x of + (ColumnSqlExpr attr) -> + not (attr `elem` groupableAttrs) + _ -> False) . + map fst $ orderby sql + -- List of non-aggregated columns which are only attribute expressions, i.e. + -- aliased columns. + groupableAttrs = [col | (AttrExpr col) <- map snd groupableProjections] + in [(s, e) | e@(ColumnSqlExpr s) <- eligible] -- | Takes all non-aggregate expressions in the select and adds them to -- the 'group by' clause. defaultSqlGroup :: SqlGenerator -> Assoc -> SqlSelect -> SqlSelect -defaultSqlGroup gen cols select = select { groupby = toSqlAssoc gen cols } - +defaultSqlGroup gen cols q = + let selectCols = concat (allCols q) -- List of all columns in order by, group by or 'select' clause in SqlSelect. + -- Nested search for all valid columns. + allCols :: SqlSelect -> [[(SqlColumn, SqlExpr)]] + allCols (SqlSelect { attrs = a, groupby = g, tables = t, orderby = o}) = a : g : toColExpr o : concatMap (allCols . snd) t + allCols (SqlBin _ l r) = allCols l ++ allCols r + allCols _ = [] + -- Convert order by expressions to SqlColumn looking expressions. + -- Luckily, order by never has antyhig but ColumnSqlExpr in it for now. + toColExpr :: [(SqlExpr,SqlOrder)] -> [(SqlColumn,SqlExpr)] + toColExpr = + let f (ColumnSqlExpr s) = Just (s, undefined) + in catMaybes . map (f . fst) + -- Ensure that each column in the groupby actually exists + -- in the projection. Also converts all expressions + -- to ColumnSqlExpr so they work correctly in group by. + mkValidCol (name, expr) = + case lookup name selectCols of + Just _ -> Just (name, sqlExpr gen expr) + Nothing -> Nothing + select = toSqlSelect q + groupbys = catMaybes . map mkValidCol $ cols + in select { groupby = groupbys } + defaultSqlRestrict :: SqlGenerator -> PrimExpr -> SqlSelect -> SqlSelect defaultSqlRestrict gen expr q = sql { criteria = sqlExpr gen expr : criteria sql } @@ -173,13 +211,41 @@ OpAsc -> SqlAsc OpDesc -> SqlDesc +-- | Make sure our SqlSelect statement is really a SqlSelect and not +-- one other constructors. 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)] } + (SqlSelect { groupby = group, attrs = cols, tables = tbls}) + | null cols && null group -> sql + | null cols && not (null group) -> + -- This situation arises when a columns used in a group by are + -- not explicitly projected, or only aggregates are. + -- + -- We make the groupby its own "subquery" below which projects + -- only "group by" columns, without introducing any aliases. We then + -- create a new select which projects the original columns projected by + -- the group by (i.e. those in the "tables" slot of the groupby select). + -- + -- This addresses a bug where GROUP BY statements would disappear + -- if the query did not use the grouped columns, or the would + -- float out of subqueries indirectly. + -- + let removeDups = nubBy (\(c1, _) (c2, _) -> c1 == c2) + -- Makes a list of columns pass-through - i.e. projected + -- with no aliasing. + passThrough = map ((\c -> (c, ColumnSqlExpr c)) . fst) + -- List of columns projected by subquery found in tables field. + currProj = passThrough $ concatMap (attrs . snd) tbls + -- Columns projected due the group by + groupProj = passThrough group + newSql = sql { attrs = removeDups $ groupProj ++ currProj } + in newSelect { attrs = currProj + , tables = [("", newSql)]} + | otherwise -> newSelect { tables = [("",sql)] } + toSqlAssoc :: SqlGenerator -> Assoc -> [(SqlColumn,SqlExpr)] toSqlAssoc gen = map (\(attr,expr) -> (attr, sqlExpr gen expr)) @@ -287,7 +353,25 @@ 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) + _ -> (leftE, rightE) + in BinSqlExpr (showBinOp op) expL expR UnExpr op e -> let (op',t) = sqlUnOp op e' = sqlExpr gen e in case t of @@ -302,6 +386,9 @@ 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 = "=" @@ -365,6 +452,9 @@ where fmt = iso8601DateFormat (Just "%H:%M:%S") OtherLit l -> l + +defaultSqlQuote :: SqlGenerator -> String -> String +defaultSqlQuote gen s = quote s -- | Quote a string and escape characters that need escaping -- FIXME: this is backend dependent diff --git a/src/Database/HaskellDB/Sql/Generate.hs b/src/Database/HaskellDB/Sql/Generate.hs --- a/src/Database/HaskellDB/Sql/Generate.hs +++ b/src/Database/HaskellDB/Sql/Generate.hs @@ -43,5 +43,8 @@ sqlExpr :: PrimExpr -> SqlExpr, sqlLiteral :: Literal -> String, - sqlType :: FieldType -> SqlType + sqlType :: FieldType -> SqlType, + -- | Turn a string into a quoted string. Quote characters + -- and any escaping are handled by this function. + sqlQuote :: String -> String } diff --git a/src/Database/HaskellDB/Sql/PostgreSQL.hs b/src/Database/HaskellDB/Sql/PostgreSQL.hs --- a/src/Database/HaskellDB/Sql/PostgreSQL.hs +++ b/src/Database/HaskellDB/Sql/PostgreSQL.hs @@ -18,18 +18,37 @@ 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" + +-- Postgres < 7.1 assumed timestamp meant with a time zone, afterwards, +-- 'timestamp with time zone' is now required. +postgresqlType CalendarTimeT = SqlType "timestamp with time zone" postgresqlType t = defaultSqlType generator t + +postgresqlExpr :: PrimExpr -> SqlExpr +postgresqlExpr (BinExpr OpMod e1 e2) = + let e1S = defaultSqlExpr generator e1 + e2S = defaultSqlExpr generator e2 + in BinSqlExpr "%" e1S e2S +postgresqlExpr e = defaultSqlExpr generator e diff --git a/src/Database/HaskellDB/Sql/Print.hs b/src/Database/HaskellDB/Sql/Print.hs --- a/src/Database/HaskellDB/Sql/Print.hs +++ b/src/Database/HaskellDB/Sql/Print.hs @@ -167,7 +167,8 @@ 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) @@ -178,6 +179,10 @@ <+> 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