haskelldb 0.12 → 0.13
raw patch · 11 files changed
+556/−65 lines, 11 filesdep ~basedep ~directorydep ~mtl
Dependency ranges changed: base, directory, mtl, old-locale, old-time, pretty
Files
- haskelldb.cabal +6/−5
- src/Database/HaskellDB.hs +56/−3
- src/Database/HaskellDB/Optimize.hs +8/−9
- src/Database/HaskellDB/PrimQuery.hs +33/−9
- src/Database/HaskellDB/PrintQuery.hs +131/−0
- src/Database/HaskellDB/Query.hs +179/−21
- src/Database/HaskellDB/Sql.hs +8/−0
- src/Database/HaskellDB/Sql/Default.hs +101/−11
- src/Database/HaskellDB/Sql/Generate.hs +4/−1
- src/Database/HaskellDB/Sql/PostgreSQL.hs +24/−5
- src/Database/HaskellDB/Sql/Print.hs +6/−1
haskelldb.cabal 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.@@ -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,
src/Database/HaskellDB.hs view
@@ -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" <jgbailey@gmail.com> -- 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 _ = []
src/Database/HaskellDB/Optimize.hs view
@@ -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
src/Database/HaskellDB/PrimQuery.hs view
@@ -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)
+ src/Database/HaskellDB/PrintQuery.hs view
@@ -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
src/Database/HaskellDB/Query.hs view
@@ -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))
src/Database/HaskellDB/Sql.hs view
@@ -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.
src/Database/HaskellDB/Sql/Default.hs view
@@ -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
src/Database/HaskellDB/Sql/Generate.hs view
@@ -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 }
src/Database/HaskellDB/Sql/PostgreSQL.hs view
@@ -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
src/Database/HaskellDB/Sql/Print.hs view
@@ -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