haskelldb 2.2.2 → 2.2.4

raw patch · 10 files changed

+195/−163 lines, 10 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• haskelldb.cabal +1/−1
• src/Database/HaskellDB.hs +1/−1
• src/Database/HaskellDB/BoundedList.hs +4/−1
• src/Database/HaskellDB/FieldType.hs +2/−6
• src/Database/HaskellDB/Optimize.hs +10/−5
• src/Database/HaskellDB/PrimQuery.hs +3/−0
• src/Database/HaskellDB/PrintQuery.hs +144/−144
• src/Database/HaskellDB/Query.hs +16/−2
• src/Database/HaskellDB/Sql/Default.hs +12/−2
• src/Database/HaskellDB/Sql/Print.hs +2/−1

@@ -1,5 +1,5 @@ Name: haskelldb-Version: 2.2.2+Version: 2.2.4 Cabal-version: >= 1.6 Build-type: Simple Homepage: https://github.com/m4dc4p/haskelldb

@@ -62,7 +62,7 @@   , count, _sum, _max, _min, avg   , stddev, stddevP, variance, varianceP   , asc, desc, order-  , top , _case , _default+  , top, offset, _case , _default    -- * Database operations   , Database				-- abstract

@@ -79,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 @@ -1372,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

@@ -1,5 +1,5 @@ {-# LANGUAGE FlexibleContexts, UndecidableInstances, TypeSynonymInstances, FlexibleInstances-  , MultiParamTypeClasses #-}+  , MultiParamTypeClasses, StandaloneDeriving #-} ----------------------------------------------------------- -- | -- Module      :  FieldType@@ -80,11 +80,7 @@     unRel :: (Rel r) -> r     unRel r = undefined -- Only used to get to type-level information. -instance Typeable CalendarTime where -- not available in standard libraries-    typeOf _ = mkTyConApp (mkTyCon "System.Time.CalendarTime") []--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)

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

@@ -65,6 +65,7 @@  data RelOp      = Times                  | Union+                | UnionAll                 | Intersect                  | Divide                  | Difference@@ -72,6 +73,7 @@  data SpecialOp  = Order [OrderExpr] 		| Top Int+		| Offset Int 		deriving (Show)  data OrderExpr = OrderExpr OrderOp PrimExpr @@ -152,6 +154,7 @@ attributes (Binary op q1 q2)    = case op of                                     Times       -> attr1 `union` attr2                                     Union       -> attr1+                                    UnionAll    -> attr1                                     Intersect   -> attr1                                     Divide      -> attr1                                      Difference  -> attr1

@@ -1,145 +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
+-----------------------------------------------------------+-- |+-- 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

@@ -32,7 +32,7 @@              , (<<), (<<-) 	      -- * Function declarations 	     , project, restrict, table, unique-	     , union, intersect, divide, minus+	     , union, unionAll, intersect, divide, minus 	     , _not, like, _in, cat, _length 	     , isNull, notNull 	     , fromNull, fromVal@@ -41,7 +41,7 @@ 	     , toStr, coerce , select 	     , count, _sum, _max, _min, avg , literal 	     , stddev, stddevP, variance, varianceP-	     , asc, desc, order , top+	     , asc, desc, order , top, offset 	     , _case , _default 	     -- * Internals 	     , runQuery, runQueryRel, unQuery@@ -55,6 +55,8 @@ import Database.HaskellDB.BoundedString import Database.HaskellDB.BoundedList +import Control.Applicative+import Control.Monad import System.Time (CalendarTime)  -----------------------------------------------------------@@ -303,6 +305,10 @@ 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@@ -732,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 -----------------------------------------------------------@@ -801,6 +811,10 @@   (Query g) >>= f       = Query (\q0 -> let (x,q1)    = g q0                                             (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)))

@@ -266,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)@@ -315,6 +318,7 @@  toSqlOp :: RelOp -> String toSqlOp Union        = "UNION"+toSqlOp UnionAll     = "UNION ALL" toSqlOp Intersect    = "INTERSECT" toSqlOp Divide       = "DIVIDE" toSqlOp Difference   = "EXCEPT"@@ -433,13 +437,19 @@                 (paren leftE, rightE)               (OpOr, e1, e2@(BinExpr OpAnd _ _)) ->                 (leftE, paren rightE)-              _ -> (leftE, 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

@@ -71,7 +71,8 @@ ppWhere :: [SqlExpr] -> Doc ppWhere [] = empty ppWhere es = text "WHERE" -             <+> hsep (intersperse (text "AND") (map ppSqlExpr es))+             <+> hsep (intersperse (text "AND")+                       (map (parens . ppSqlExpr) es))  ppGroupBy :: Mark -> Doc ppGroupBy All = error "Should not ever print GroupBy all."