diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,10 @@ +## 0.4.2.0 + +* Added `.===` and `./==` for comparison of product types +* Added `keepWhen` as an alternative to `restrict` +* Added `constant` conversion to and from Aeson +* Added `pgValueJSON` and `pgValueJSONB` + ## 0.4.1.0 * Added `Opaleye.Constant` for lifting constant values diff --git a/Doc/Tutorial/TutorialBasic.lhs b/Doc/Tutorial/TutorialBasic.lhs --- a/Doc/Tutorial/TutorialBasic.lhs +++ b/Doc/Tutorial/TutorialBasic.lhs @@ -64,6 +64,10 @@ > , required "age" > , required "address" )) +By default, the table `"personTable"` is looked up in PostgreSQL's +default `"public"` schema. If we wanted to specify a different schema we +could have used the `TableWithSchema` constructor instead of `Table`. + To query a table we use `queryTable`. (Here and in a few other places in Opaleye there is some typeclass diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -20,12 +20,17 @@ composable at a very fine level of granularity, promoting code reuse and high levels of abstraction. +## Getting Opaleye + +* Github: https://github.com/tomjaguarpaw/haskell-opaleye +* Hackage: https://hackage.haskell.org/package/opaleye + ## Tutorials Please get started with Opaleye by referring to these two tutorials -* [Basic tutorial](Doc/Tutorial/TutorialBasic.lhs) -* [Manipulation tutorial](Doc/Tutorial/TutorialManipulation.lhs) +* [Basic tutorial](https://github.com/tomjaguarpaw/haskell-opaleye/blob/master/Doc/Tutorial/TutorialBasic.lhs) +* [Manipulation tutorial](https://github.com/tomjaguarpaw/haskell-opaleye/blob/master/Doc/Tutorial/TutorialManipulation.lhs) # Contact diff --git a/Test/Test.hs b/Test/Test.hs --- a/Test/Test.hs +++ b/Test/Test.hs @@ -137,7 +137,7 @@ table5 :: O.Table (Maybe (Column O.PGInt4), Maybe (Column O.PGInt4)) (Column O.PGInt4, Column O.PGInt4) -table5 = O.Table "table5" (PP.p2 (O.optional "column1", O.optional "column2")) +table5 = O.TableWithSchema "public" "table5" (PP.p2 (O.optional "column1", O.optional "column2")) table6 :: O.Table (Column O.PGText, Column O.PGText) (Column O.PGText, Column O.PGText) table6 = O.Table "table6" (PP.p2 (O.required "column1", O.required "column2")) @@ -209,8 +209,8 @@ -- table names are treated as lower case unless the name is quoted! dropAndCreateTable :: String -> (String, [String]) -> PGS.Query dropAndCreateTable columnType (t, cols) = String.fromString drop_ - where drop_ = "DROP TABLE IF EXISTS \"" ++ t ++ "\";" - ++ "CREATE TABLE \"" ++ t ++ "\"" + where drop_ = "DROP TABLE IF EXISTS \"public\".\"" ++ t ++ "\";" + ++ "CREATE TABLE \"public\".\"" ++ t ++ "\"" ++ " (" ++ commas cols ++ ");" integer c = ("\"" ++ c ++ "\"" ++ " " ++ columnType) commas = L.intercalate "," . map integer @@ -225,8 +225,8 @@ -- table names are treated as lower case unless the name is quoted! dropAndCreateTableSerial :: (String, [String]) -> PGS.Query dropAndCreateTableSerial (t, cols) = String.fromString drop_ - where drop_ = "DROP TABLE IF EXISTS \"" ++ t ++ "\";" - ++ "CREATE TABLE \"" ++ t ++ "\"" + where drop_ = "DROP TABLE IF EXISTS \"public\".\"" ++ t ++ "\";" + ++ "CREATE TABLE \"public\".\"" ++ t ++ "\"" ++ " (" ++ commas cols ++ ");" integer c = ("\"" ++ c ++ "\"" ++ " SERIAL") commas = L.intercalate "," . map integer diff --git a/opaleye.cabal b/opaleye.cabal --- a/opaleye.cabal +++ b/opaleye.cabal @@ -1,6 +1,6 @@ name: opaleye copyright: Copyright (c) 2014-2015 Purely Agile Limited -version: 0.4.1.0 +version: 0.4.2.0 synopsis: An SQL-generating DSL targeting PostgreSQL description: An SQL-generating DSL targeting PostgreSQL. Allows Postgres queries to be written within Haskell in a @@ -27,17 +27,18 @@ build-depends: -- attoparsec can be removed once postgresql-simple patch in -- Internal.RunQuery is merged upstream - attoparsec >= 0.10.3 && < 0.14 + aeson >= 0.6 && < 0.11 + , attoparsec >= 0.10.3 && < 0.14 , base >= 4 && < 5 , base16-bytestring >= 0.1.1.6 && < 0.2 , case-insensitive >= 1.2 && < 1.3 , bytestring >= 0.10 && < 0.11 , contravariant >= 1.2 && < 1.4 - , postgresql-simple >= 0.4.8.0 && < 0.5 + , postgresql-simple >= 0.4.8.0 && < 0.6 , pretty >= 1.1.1.0 && < 1.2 , product-profunctors >= 0.6.2 && < 0.7 , profunctors >= 4.0 && < 5.2 - , semigroups >= 0.13 && < 0.17 + , semigroups >= 0.13 && < 0.18 , text >= 0.11 && < 1.3 , transformers >= 0.3 && < 0.5 , time >= 1.4 && < 1.6 @@ -67,6 +68,7 @@ Opaleye.Internal.Helpers, Opaleye.Internal.Join, Opaleye.Internal.Order, + Opaleye.Internal.Operators, Opaleye.Internal.Optimize, Opaleye.Internal.PackMap, Opaleye.Internal.PGTypes, diff --git a/src/Opaleye/Constant.hs b/src/Opaleye/Constant.hs --- a/src/Opaleye/Constant.hs +++ b/src/Opaleye/Constant.hs @@ -6,6 +6,7 @@ import qualified Opaleye.Column as C import qualified Opaleye.PGTypes as T +import qualified Data.Aeson as Ae import qualified Data.CaseInsensitive as CI import qualified Data.Int as Int import qualified Data.Text as ST @@ -89,11 +90,17 @@ instance D.Default Constant LBS.ByteString (Column T.PGJson) where def = Constant T.pgLazyJSON +instance D.Default Constant Ae.Value (Column T.PGJson) where + def = Constant T.pgValueJSON + instance D.Default Constant SBS.ByteString (Column T.PGJsonb) where def = Constant T.pgStrictJSONB instance D.Default Constant LBS.ByteString (Column T.PGJsonb) where def = Constant T.pgLazyJSONB + +instance D.Default Constant Ae.Value (Column T.PGJsonb) where + def = Constant T.pgValueJSONB -- { Boilerplate instances diff --git a/src/Opaleye/Internal/Column.hs b/src/Opaleye/Internal/Column.hs --- a/src/Opaleye/Internal/Column.hs +++ b/src/Opaleye/Internal/Column.hs @@ -2,9 +2,8 @@ import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ --- | The 'Num' and 'Fractional' instances for 'Column' 'a' are too --- general. For example, they allow you to add two 'Column' --- 'String's. This will be fixed in a subsequent release. +-- | Numeric 'Column' types are instances of 'Num', so you can use +-- '*', '/', '+', '-' on them. newtype Column a = Column HPQ.PrimExpr deriving Show data Nullable a = Nullable diff --git a/src/Opaleye/Internal/HaskellDB/Sql.hs b/src/Opaleye/Internal/HaskellDB/Sql.hs --- a/src/Opaleye/Internal/HaskellDB/Sql.hs +++ b/src/Opaleye/Internal/HaskellDB/Sql.hs @@ -11,7 +11,10 @@ -- * SQL data type ----------------------------------------------------------- -newtype SqlTable = SqlTable String deriving Show +data SqlTable = SqlTable + { sqlTableSchemaName :: Maybe String + , sqlTableName :: String + } deriving Show newtype SqlColumn = SqlColumn String deriving Show diff --git a/src/Opaleye/Internal/HaskellDB/Sql/Default.hs b/src/Opaleye/Internal/HaskellDB/Sql/Default.hs --- a/src/Opaleye/Internal/HaskellDB/Sql/Default.hs +++ b/src/Opaleye/Internal/HaskellDB/Sql/Default.hs @@ -50,29 +50,29 @@ defaultSqlUpdate :: SqlGenerator - -> TableName -- ^ Name of the table to update. + -> SqlTable -- ^ Table to update -> [PrimExpr] -- ^ Conditions which must all be true for a row -- to be updated. -> Assoc -- ^ Update the data with this. -> SqlUpdate -defaultSqlUpdate gen name criteria assigns - = SqlUpdate (SqlTable name) (toSqlAssoc gen assigns) (map (sqlExpr gen) criteria) +defaultSqlUpdate gen tbl criteria assigns + = SqlUpdate tbl (toSqlAssoc gen assigns) (map (sqlExpr gen) criteria) defaultSqlInsert :: SqlGenerator - -> TableName + -> SqlTable -> [Attribute] -> NEL.NonEmpty [PrimExpr] -> SqlInsert -defaultSqlInsert gen name attrs exprs = - SqlInsert (SqlTable name) (map toSqlColumn attrs) ((fmap . map) (sqlExpr gen) exprs) +defaultSqlInsert gen tbl attrs exprs = + SqlInsert tbl (map toSqlColumn attrs) ((fmap . map) (sqlExpr gen) exprs) defaultSqlDelete :: SqlGenerator - -> TableName -- ^ Name of the table + -> SqlTable -> [PrimExpr] -- ^ Criteria which must all be true for a row -- to be deleted. -> SqlDelete -defaultSqlDelete gen name criteria = SqlDelete (SqlTable name) (map (sqlExpr gen) criteria) +defaultSqlDelete gen tbl criteria = SqlDelete tbl (map (sqlExpr gen) criteria) defaultSqlExpr :: SqlGenerator -> PrimExpr -> SqlExpr diff --git a/src/Opaleye/Internal/HaskellDB/Sql/Generate.hs b/src/Opaleye/Internal/HaskellDB/Sql/Generate.hs --- a/src/Opaleye/Internal/HaskellDB/Sql/Generate.hs +++ b/src/Opaleye/Internal/HaskellDB/Sql/Generate.hs @@ -11,9 +11,9 @@ data SqlGenerator = SqlGenerator { - sqlUpdate :: TableName -> [PrimExpr] -> Assoc -> SqlUpdate, - sqlDelete :: TableName -> [PrimExpr] -> SqlDelete, - sqlInsert :: TableName -> [Attribute] -> NEL.NonEmpty [PrimExpr] -> SqlInsert, + sqlUpdate :: SqlTable -> [PrimExpr] -> Assoc -> SqlUpdate, + sqlDelete :: SqlTable -> [PrimExpr] -> SqlDelete, + sqlInsert :: SqlTable -> [Attribute] -> NEL.NonEmpty [PrimExpr] -> SqlInsert, sqlExpr :: PrimExpr -> SqlExpr, sqlLiteral :: Literal -> String, -- | Turn a string into a quoted string. Quote characters diff --git a/src/Opaleye/Internal/HaskellDB/Sql/Print.hs b/src/Opaleye/Internal/HaskellDB/Sql/Print.hs --- a/src/Opaleye/Internal/HaskellDB/Sql/Print.hs +++ b/src/Opaleye/Internal/HaskellDB/Sql/Print.hs @@ -104,10 +104,14 @@ ppColumn :: SqlColumn -> Doc ppColumn (SqlColumn s) = doubleQuotes (text s) --- Postgres treats upper case letters in table names as lower case, --- unless the name is quoted! +-- Postgres treats schema and table names as lower case unless quoted. ppTable :: SqlTable -> Doc -ppTable (SqlTable s) = doubleQuotes (text s) +ppTable st = case sqlTableSchemaName st of + Just sn -> doubleQuotes (text sn) <> text "." <> tname + Nothing -> tname + where + tname = doubleQuotes (text (sqlTableName st)) + ppSqlExpr :: SqlExpr -> Doc ppSqlExpr expr = diff --git a/src/Opaleye/Internal/Operators.hs b/src/Opaleye/Internal/Operators.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/Internal/Operators.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Opaleye.Internal.Operators where + +import Opaleye.Internal.Column (Column) +import qualified Opaleye.Internal.Column as C +import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ +import qualified Opaleye.PGTypes as T + +import Data.Profunctor (Profunctor, dimap) +import Data.Profunctor.Product (ProductProfunctor, empty, (***!)) +import qualified Data.Profunctor.Product.Default as D + +infix 4 .== +(.==) :: forall columns. D.Default EqPP columns columns + => columns -> columns -> Column T.PGBool +(.==) = eqExplicit (D.def :: EqPP columns columns) + +infixr 3 .&& +(.&&) :: Column T.PGBool -> Column T.PGBool -> Column T.PGBool +(.&&) = C.binOp HPQ.OpAnd + +data EqPP a b = EqPP (a -> a -> Column T.PGBool) + +eqExplicit :: EqPP columns a -> columns -> columns -> Column T.PGBool +eqExplicit (EqPP f) = f + +instance D.Default EqPP (Column a) (Column a) where + def = EqPP C.unsafeEq + +-- { Boilerplate instances + +instance Profunctor EqPP where + dimap f _ (EqPP h) = EqPP (\a a' -> h (f a) (f a')) + +instance ProductProfunctor EqPP where + empty = EqPP (\() () -> T.pgBool True) + EqPP f ***! EqPP f' = EqPP (\a a' -> + f (fst a) (fst a') .&& f' (snd a) (snd a')) + +-- } diff --git a/src/Opaleye/Internal/PrimQuery.hs b/src/Opaleye/Internal/PrimQuery.hs --- a/src/Opaleye/Internal/PrimQuery.hs +++ b/src/Opaleye/Internal/PrimQuery.hs @@ -3,6 +3,7 @@ import Prelude hiding (product) import qualified Data.List.NonEmpty as NEL +import qualified Opaleye.Internal.HaskellDB.Sql as HSql import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ import Opaleye.Internal.HaskellDB.PrimQuery (Symbol) @@ -12,13 +13,23 @@ data BinOp = Except | Union | UnionAll deriving Show data JoinType = LeftJoin deriving Show +data TableIdentifier = TableIdentifier + { tiSchemaName :: Maybe String + , tiTableName :: String + } deriving Show + +tiToSqlTable :: TableIdentifier -> HSql.SqlTable +tiToSqlTable ti = HSql.SqlTable { HSql.sqlTableSchemaName = tiSchemaName ti + , HSql.sqlTableName = tiTableName ti } + + -- In the future it may make sense to introduce this datatype -- type Bindings a = [(Symbol, a)] -- We use a 'NEL.NonEmpty' for Product because otherwise we'd have to check -- for emptiness explicity in the SQL generation phase. data PrimQuery = Unit - | BaseTable String [(Symbol, HPQ.PrimExpr)] + | BaseTable TableIdentifier [(Symbol, HPQ.PrimExpr)] | Product (NEL.NonEmpty PrimQuery) [HPQ.PrimExpr] | Aggregate [(Symbol, (Maybe HPQ.AggrOp, HPQ.PrimExpr))] PrimQuery | Order [HPQ.OrderExpr] PrimQuery @@ -29,7 +40,7 @@ deriving Show type PrimQueryFold p = ( p - , String -> [(Symbol, HPQ.PrimExpr)] -> p + , TableIdentifier -> [(Symbol, HPQ.PrimExpr)] -> p , NEL.NonEmpty p -> [HPQ.PrimExpr] -> p , [(Symbol, (Maybe HPQ.AggrOp, HPQ.PrimExpr))] -> p -> p , [HPQ.OrderExpr] -> p -> p @@ -44,7 +55,7 @@ binary) = fix fold where fold self primQ = case primQ of Unit -> unit - BaseTable n s -> baseTable n s + BaseTable ti syms -> baseTable ti syms Product pqs pes -> product (fmap self pqs) pes Aggregate aggrs pq -> aggregate aggrs (self pq) Order pes pq -> order pes (self pq) diff --git a/src/Opaleye/Internal/RunQuery.hs b/src/Opaleye/Internal/RunQuery.hs --- a/src/Opaleye/Internal/RunQuery.hs +++ b/src/Opaleye/Internal/RunQuery.hs @@ -24,6 +24,7 @@ import Data.Profunctor.Product (empty, (***!)) import qualified Data.Profunctor.Product.Default as D +import qualified Data.Aeson as Ae import qualified Data.CaseInsensitive as CI import qualified Data.Text as ST import qualified Data.Text.Lazy as LT @@ -173,9 +174,15 @@ queryRunnerColumnDefault = QueryRunnerColumn (P.rmap (const ()) U.unpackspecColumn) jsonFieldParser +instance QueryRunnerColumnDefault T.PGJson Ae.Value where + queryRunnerColumnDefault = fieldQueryRunnerColumn + instance QueryRunnerColumnDefault T.PGJsonb String where queryRunnerColumnDefault = QueryRunnerColumn (P.rmap (const ()) U.unpackspecColumn) jsonbFieldParser + +instance QueryRunnerColumnDefault T.PGJsonb Ae.Value where + queryRunnerColumnDefault = fieldQueryRunnerColumn -- No CI String instance since postgresql-simple doesn't define FromField (CI String) diff --git a/src/Opaleye/Internal/Sql.hs b/src/Opaleye/Internal/Sql.hs --- a/src/Opaleye/Internal/Sql.hs +++ b/src/Opaleye/Internal/Sql.hs @@ -61,8 +61,6 @@ data JoinType = LeftJoin deriving Show data BinOp = Except | Union | UnionAll deriving Show -data TableName = String - data Returning a = Returning a (NEL.NonEmpty HSql.SqlExpr) sqlQueryGenerator :: PQ.PrimQueryFold Select @@ -79,10 +77,10 @@ unit :: Select unit = SelectFrom newSelect { attrs = SelectAttrs (ensureColumns []) } -baseTable :: String -> [(Symbol, HPQ.PrimExpr)] -> Select -baseTable name columns = SelectFrom $ +baseTable :: PQ.TableIdentifier -> [(Symbol, HPQ.PrimExpr)] -> Select +baseTable ti columns = SelectFrom $ newSelect { attrs = SelectAttrs (ensureColumns (map sqlBinding columns)) - , tables = [Table (HSql.SqlTable name)] } + , tables = [Table (HSql.SqlTable (PQ.tiSchemaName ti) (PQ.tiTableName ti))] } product :: NEL.NonEmpty Select -> [HPQ.PrimExpr] -> Select product ss pes = SelectFrom $ diff --git a/src/Opaleye/Internal/Table.hs b/src/Opaleye/Internal/Table.hs --- a/src/Opaleye/Internal/Table.hs +++ b/src/Opaleye/Internal/Table.hs @@ -45,12 +45,25 @@ -- , quantity = required \"quantity\" -- , radius = required \"radius\" }) -- @ -data Table writerColumns viewColumns = - Table String (TableProperties writerColumns viewColumns) +data Table writerColumns viewColumns + = Table String (TableProperties writerColumns viewColumns) + -- ^ Uses the default schema name (@"public"@). + | TableWithSchema String String (TableProperties writerColumns viewColumns) + -- ^ Schema name (@"public"@ by default in PostgreSQL), table name, + -- table properties. -data TableProperties writerColumns viewColumns = - TableProperties (Writer writerColumns viewColumns) (View viewColumns) +tableIdentifier :: Table writerColumns viewColumns -> PQ.TableIdentifier +tableIdentifier (Table t _) = PQ.TableIdentifier Nothing t +tableIdentifier (TableWithSchema s t _) = PQ.TableIdentifier (Just s) t +tableProperties :: Table writerColumns viewColumns -> TableProperties writerColumns viewColumns +tableProperties (Table _ p) = p +tableProperties (TableWithSchema _ _ p) = p + +data TableProperties writerColumns viewColumns = TableProperties + { tablePropertiesWriter :: Writer writerColumns viewColumns + , tablePropertiesView :: View viewColumns } + data View columns = View columns -- There's no reason the second parameter should exist except that we @@ -71,10 +84,10 @@ -> Tag.Tag -> (columns, PQ.PrimQuery) queryTable cm table tag = (primExprs, primQ) where - (Table tableName (TableProperties _ (View tableCols))) = table + View tableCols = tablePropertiesView (tableProperties table) (primExprs, projcols) = runColumnMaker cm tag tableCols primQ :: PQ.PrimQuery - primQ = PQ.BaseTable tableName projcols + primQ = PQ.BaseTable (tableIdentifier table) projcols runColumnMaker :: TM.ColumnMaker tablecolumns columns -> Tag.Tag @@ -158,6 +171,7 @@ (***!) = PP.defaultProfunctorProduct instance Functor (Table a) where - fmap f (Table s tp) = Table s (fmap f tp) + fmap f (Table t tp) = Table t (fmap f tp) + fmap f (TableWithSchema s t tp) = TableWithSchema s t (fmap f tp) -- } diff --git a/src/Opaleye/Manipulation.hs b/src/Opaleye/Manipulation.hs --- a/src/Opaleye/Manipulation.hs +++ b/src/Opaleye/Manipulation.hs @@ -11,6 +11,7 @@ import qualified Opaleye.Internal.Table as TI import Opaleye.Internal.Column (Column(Column)) import Opaleye.Internal.Helpers ((.:), (.:.), (.::), (.::.)) +import qualified Opaleye.Internal.PrimQuery as PQ import qualified Opaleye.Internal.Unpackspec as U import Opaleye.PGTypes (PGBool) @@ -27,24 +28,9 @@ import Data.String (fromString) import qualified Data.List.NonEmpty as NEL -arrangeInsert :: T.Table columns a -> columns -> HSql.SqlInsert -arrangeInsert t c = arrangeInsertMany t (return c) - -arrangeInsertSql :: T.Table columns a -> columns -> String -arrangeInsertSql = show . HPrint.ppInsert .: arrangeInsert - runInsert :: PGS.Connection -> T.Table columns columns' -> columns -> IO Int64 runInsert conn = PGS.execute_ conn . fromString .: arrangeInsertSql -arrangeInsertMany :: T.Table columns a -> NEL.NonEmpty columns -> HSql.SqlInsert -arrangeInsertMany (T.Table tableName (TI.TableProperties writer _)) columns = insert - where (columnExprs, columnNames) = TI.runWriter' writer columns - insert = SG.sqlInsert SD.defaultSqlGenerator - tableName columnNames columnExprs - -arrangeInsertManySql :: T.Table columns a -> NEL.NonEmpty columns -> String -arrangeInsertManySql = show . HPrint.ppInsert .: arrangeInsertMany - runInsertMany :: PGS.Connection -> T.Table columns columns' -> [columns] @@ -54,40 +40,140 @@ Nothing -> return 0 Just columns' -> (PGS.execute_ conn . fromString .: arrangeInsertManySql) table columns' +-- | @runInsertReturning@'s use of the 'D.Default' typeclass means that the +-- compiler will have trouble inferring types. It is strongly +-- recommended that you provide full type signatures when using +-- @runInsertReturning@. +runInsertReturning :: (D.Default RQ.QueryRunner returned haskells) + => PGS.Connection + -> T.Table columnsW columnsR + -> columnsW + -> (columnsR -> returned) + -> IO [haskells] +runInsertReturning = runInsertReturningExplicit D.def + +-- | Where the predicate is true, update rows using the supplied +-- function. +runUpdate :: PGS.Connection -> T.Table columnsW columnsR + -> (columnsR -> columnsW) -> (columnsR -> Column PGBool) + -> IO Int64 +runUpdate conn = PGS.execute_ conn . fromString .:. arrangeUpdateSql + +-- | @runUpdateReturning@'s use of the 'D.Default' typeclass means +-- that the compiler will have trouble inferring types. It is +-- strongly recommended that you provide full type signatures when +-- using @runInsertReturning@. +runUpdateReturning :: (D.Default RQ.QueryRunner returned haskells) + => PGS.Connection + -> T.Table columnsW columnsR + -> (columnsR -> columnsW) + -> (columnsR -> Column PGBool) + -> (columnsR -> returned) + -> IO [haskells] +runUpdateReturning = runUpdateReturningExplicit D.def + +-- | Delete rows where the predicate is true. +runDelete :: PGS.Connection -> T.Table a columnsR -> (columnsR -> Column PGBool) + -> IO Int64 +runDelete conn = PGS.execute_ conn . fromString .: arrangeDeleteSql + +-- | You probably don't need this, but can just use +-- 'runInsertReturning' instead. You only need it if you want to run +-- an UPDATE RETURNING statement but need to be explicit about the +-- 'QueryRunner'. +runInsertReturningExplicit :: RQ.QueryRunner returned haskells + -> PGS.Connection + -> T.Table columnsW columnsR + -> columnsW + -> (columnsR -> returned) + -> IO [haskells] +runInsertReturningExplicit qr conn t w r = PGS.queryWith_ parser conn + (fromString + (arrangeInsertReturningSql u t w r)) + where IRQ.QueryRunner u _ _ = qr + parser = IRQ.prepareRowParser qr (r v) + TI.Table _ (TI.TableProperties _ (TI.View v)) = t + -- This method of getting hold of the return type feels a bit + -- suspect. I haven't checked it for validity. + +-- | You probably don't need this, but can just use +-- 'runUpdateReturning' instead. You only need it if you want to run +-- an UPDATE RETURNING statement but need to be explicit about the +-- 'QueryRunner'. +runUpdateReturningExplicit :: RQ.QueryRunner returned haskells + -> PGS.Connection + -> T.Table columnsW columnsR + -> (columnsR -> columnsW) + -> (columnsR -> Column PGBool) + -> (columnsR -> returned) + -> IO [haskells] +runUpdateReturningExplicit qr conn t update cond r = + PGS.queryWith_ parser conn + (fromString (arrangeUpdateReturningSql u t update cond r)) + where IRQ.QueryRunner u _ _ = qr + parser = IRQ.prepareRowParser qr (r v) + TI.Table _ (TI.TableProperties _ (TI.View v)) = t + +-- | For internal use only. Do not use. Will be removed in a +-- subsequent release. +arrangeInsert :: T.Table columns a -> columns -> HSql.SqlInsert +arrangeInsert t c = arrangeInsertMany t (return c) + +-- | For internal use only. Do not use. Will be removed in a +-- subsequent release. +arrangeInsertSql :: T.Table columns a -> columns -> String +arrangeInsertSql = show . HPrint.ppInsert .: arrangeInsert + +-- | For internal use only. Do not use. Will be removed in a +-- subsequent release. +arrangeInsertMany :: T.Table columns a -> NEL.NonEmpty columns -> HSql.SqlInsert +arrangeInsertMany table columns = insert + where writer = TI.tablePropertiesWriter (TI.tableProperties table) + (columnExprs, columnNames) = TI.runWriter' writer columns + insert = SG.sqlInsert SD.defaultSqlGenerator + (PQ.tiToSqlTable (TI.tableIdentifier table)) + columnNames columnExprs + +-- | For internal use only. Do not use. Will be removed in a +-- subsequent release. +arrangeInsertManySql :: T.Table columns a -> NEL.NonEmpty columns -> String +arrangeInsertManySql = show . HPrint.ppInsert .: arrangeInsertMany + +-- | For internal use only. Do not use. Will be removed in a +-- subsequent release. arrangeUpdate :: T.Table columnsW columnsR -> (columnsR -> columnsW) -> (columnsR -> Column PGBool) -> HSql.SqlUpdate -arrangeUpdate (TI.Table tableName (TI.TableProperties writer (TI.View tableCols))) - update cond = - SG.sqlUpdate SD.defaultSqlGenerator tableName [condExpr] (update' tableCols) - where update' = map (\(x, y) -> (y, x)) - . TI.runWriter writer - . update +arrangeUpdate table update cond = + SG.sqlUpdate SD.defaultSqlGenerator + (PQ.tiToSqlTable (TI.tableIdentifier table)) + [condExpr] (update' tableCols) + where TI.TableProperties writer (TI.View tableCols) = TI.tableProperties table + update' = map (\(x, y) -> (y, x)) . TI.runWriter writer . update Column condExpr = cond tableCols +-- | For internal use only. Do not use. Will be removed in a +-- subsequent release. arrangeUpdateSql :: T.Table columnsW columnsR -> (columnsR -> columnsW) -> (columnsR -> Column PGBool) -> String arrangeUpdateSql = show . HPrint.ppUpdate .:. arrangeUpdate -runUpdate :: PGS.Connection -> T.Table columnsW columnsR - -> (columnsR -> columnsW) -> (columnsR -> Column PGBool) - -> IO Int64 -runUpdate conn = PGS.execute_ conn . fromString .:. arrangeUpdateSql - +-- | For internal use only. Do not use. Will be removed in a +-- subsequent release. arrangeDelete :: T.Table a columnsR -> (columnsR -> Column PGBool) -> HSql.SqlDelete -arrangeDelete (TI.Table tableName (TI.TableProperties _ (TI.View tableCols))) - cond = - SG.sqlDelete SD.defaultSqlGenerator tableName [condExpr] +arrangeDelete table cond = + SG.sqlDelete SD.defaultSqlGenerator (PQ.tiToSqlTable (TI.tableIdentifier table)) [condExpr] where Column condExpr = cond tableCols + TI.View tableCols = TI.tablePropertiesView (TI.tableProperties table) +-- | For internal use only. Do not use. Will be removed in a +-- subsequent release. arrangeDeleteSql :: T.Table a columnsR -> (columnsR -> Column PGBool) -> String arrangeDeleteSql = show . HPrint.ppDelete .: arrangeDelete -runDelete :: PGS.Connection -> T.Table a columnsR -> (columnsR -> Column PGBool) - -> IO Int64 -runDelete conn = PGS.execute_ conn . fromString .: arrangeDeleteSql - +-- | For internal use only. Do not use. Will be removed in a +-- subsequent release. arrangeInsertReturning :: U.Unpackspec returned ignored -> T.Table columnsW columnsR -> columnsW @@ -96,10 +182,12 @@ arrangeInsertReturning unpackspec table columns returningf = Sql.Returning insert returningSEs where insert = arrangeInsert table columns - TI.Table _ (TI.TableProperties _ (TI.View columnsR)) = table + TI.View columnsR = TI.tablePropertiesView (TI.tableProperties table) returningPEs = U.collectPEs unpackspec (returningf columnsR) returningSEs = Sql.ensureColumnsGen id (map Sql.sqlExpr returningPEs) +-- | For internal use only. Do not use. Will be removed in a +-- subsequent release. arrangeInsertReturningSql :: U.Unpackspec returned ignored -> T.Table columnsW columnsR -> columnsW @@ -109,33 +197,8 @@ . Print.ppInsertReturning .:: arrangeInsertReturning -runInsertReturningExplicit :: RQ.QueryRunner returned haskells - -> PGS.Connection - -> T.Table columnsW columnsR - -> columnsW - -> (columnsR -> returned) - -> IO [haskells] -runInsertReturningExplicit qr conn t w r = PGS.queryWith_ parser conn - (fromString - (arrangeInsertReturningSql u t w r)) - where IRQ.QueryRunner u _ _ = qr - parser = IRQ.prepareRowParser qr (r v) - TI.Table _ (TI.TableProperties _ (TI.View v)) = t - -- This method of getting hold of the return type feels a bit - -- suspect. I haven't checked it for validity. - --- | @runInsertReturning@'s use of the 'D.Default' typeclass means that the --- compiler will have trouble inferring types. It is strongly --- recommended that you provide full type signatures when using --- @runInsertReturning@. -runInsertReturning :: (D.Default RQ.QueryRunner returned haskells) - => PGS.Connection - -> T.Table columnsW columnsR - -> columnsW - -> (columnsR -> returned) - -> IO [haskells] -runInsertReturning = runInsertReturningExplicit D.def - +-- | For internal use only. Do not use. Will be removed in a +-- subsequent release. arrangeUpdateReturning :: U.Unpackspec returned ignored -> T.Table columnsW columnsR -> (columnsR -> columnsW) @@ -145,10 +208,12 @@ arrangeUpdateReturning unpackspec table updatef cond returningf = Sql.Returning update returningSEs where update = arrangeUpdate table updatef cond - TI.Table _ (TI.TableProperties _ (TI.View columnsR)) = table + TI.View columnsR = TI.tablePropertiesView (TI.tableProperties table) returningPEs = U.collectPEs unpackspec (returningf columnsR) returningSEs = Sql.ensureColumnsGen id (map Sql.sqlExpr returningPEs) +-- | For internal use only. Do not use. Will be removed in a +-- subsequent release. arrangeUpdateReturningSql :: U.Unpackspec returned ignored -> T.Table columnsW columnsR -> (columnsR -> columnsW) @@ -158,26 +223,3 @@ arrangeUpdateReturningSql = show . Print.ppUpdateReturning .::. arrangeUpdateReturning - -runUpdateReturningExplicit :: RQ.QueryRunner returned haskells - -> PGS.Connection - -> T.Table columnsW columnsR - -> (columnsR -> columnsW) - -> (columnsR -> Column PGBool) - -> (columnsR -> returned) - -> IO [haskells] -runUpdateReturningExplicit qr conn t update cond r = - PGS.queryWith_ parser conn - (fromString (arrangeUpdateReturningSql u t update cond r)) - where IRQ.QueryRunner u _ _ = qr - parser = IRQ.prepareRowParser qr (r v) - TI.Table _ (TI.TableProperties _ (TI.View v)) = t - -runUpdateReturning :: (D.Default RQ.QueryRunner returned haskells) - => PGS.Connection - -> T.Table columnsW columnsR - -> (columnsR -> columnsW) - -> (columnsR -> Column PGBool) - -> (columnsR -> returned) - -> IO [haskells] -runUpdateReturning = runUpdateReturningExplicit D.def diff --git a/src/Opaleye/Operators.hs b/src/Opaleye/Operators.hs --- a/src/Opaleye/Operators.hs +++ b/src/Opaleye/Operators.hs @@ -1,35 +1,70 @@ -module Opaleye.Operators (module Opaleye.Operators) where +{-# LANGUAGE Arrows #-} +{-# LANGUAGE FlexibleContexts #-} +-- | Operators on 'Column's. Numeric 'Column' types are instances of +-- 'Num', so you can use '*', '/', '+', '-' on them. + +module Opaleye.Operators (module Opaleye.Operators, + (O..&&)) where + +import qualified Control.Arrow as A import qualified Data.Foldable as F import Opaleye.Internal.Column (Column(Column), unsafeCase_, - unsafeIfThenElse, unsafeGt, unsafeEq) + unsafeIfThenElse, unsafeGt) import qualified Opaleye.Internal.Column as C import Opaleye.Internal.QueryArr (QueryArr(QueryArr)) import qualified Opaleye.Internal.PrimQuery as PQ +import qualified Opaleye.Internal.Operators as O +import Opaleye.Internal.Helpers ((.:)) import qualified Opaleye.Order as Ord import qualified Opaleye.PGTypes as T import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ +import qualified Data.Profunctor.Product.Default as D + {-| Restrict query results to a particular condition. Corresponds to - the guard method of the MonadPlus class. --} +the guard method of the MonadPlus class. You would typically use +'restrict' if you want to use 'A.Arrow' notation. -} restrict :: QueryArr (Column T.PGBool) () restrict = QueryArr f where f (Column predicate, primQ, t0) = ((), PQ.restrict predicate primQ, t0) +{-| Filter a 'QueryArr' to only those rows where the given condition +holds. This is the 'QueryArr' equivalent of 'Prelude.filter' from the +'Prelude'. You would typically use 'keepWhen' if you want to use a +"point free" style.-} +keepWhen :: (a -> Column T.PGBool) -> QueryArr a a +keepWhen p = proc a -> do + restrict -< p a + A.returnA -< a + doubleOfInt :: Column T.PGInt4 -> Column T.PGFloat8 doubleOfInt (Column e) = Column (HPQ.CastExpr "float8" e) infix 4 .== (.==) :: Column a -> Column a -> Column T.PGBool -(.==) = unsafeEq +(.==) = C.binOp HPQ.OpEq infix 4 ./= (./=) :: Column a -> Column a -> Column T.PGBool (./=) = C.binOp HPQ.OpNotEq +infix 4 .=== +-- | A polymorphic equality operator that works for all types that you +-- have run `makeAdaptorAndInstance` on. This may be unified with +-- `.==` in a future version. +(.===) :: D.Default O.EqPP columns columns => columns -> columns -> Column T.PGBool +(.===) = (O..==) + +infix 4 ./== +-- | A polymorphic inequality operator that works for all types that +-- you have run `makeAdaptorAndInstance` on. This may be unified with +-- `.==` in a future version. +(./==) :: D.Default O.EqPP columns columns => columns -> columns -> Column T.PGBool +(./==) = Opaleye.Operators.not .: (O..==) + infix 4 .> (.>) :: Ord.PGOrd a => Column a -> Column a -> Column T.PGBool (.>) = unsafeGt @@ -52,10 +87,6 @@ ifThenElse :: Column T.PGBool -> Column a -> Column a -> Column a ifThenElse = unsafeIfThenElse -infixr 3 .&& -(.&&) :: Column T.PGBool -> Column T.PGBool -> Column T.PGBool -(.&&) = C.binOp HPQ.OpAnd - infixr 2 .|| (.||) :: Column T.PGBool -> Column T.PGBool -> Column T.PGBool (.||) = C.binOp HPQ.OpOr @@ -75,6 +106,7 @@ like :: Column T.PGText -> Column T.PGText -> Column T.PGBool like = C.binOp HPQ.OpLike +-- | True when any element of the container is true ors :: F.Foldable f => f (Column T.PGBool) -> Column T.PGBool ors = F.foldl' (.||) (T.pgBool False) diff --git a/src/Opaleye/Order.hs b/src/Opaleye/Order.hs --- a/src/Opaleye/Order.hs +++ b/src/Opaleye/Order.hs @@ -80,3 +80,4 @@ instance PGOrd T.PGTimestamptz instance PGOrd T.PGTimestamp instance PGOrd T.PGCitext +instance PGOrd T.PGUuid diff --git a/src/Opaleye/PGTypes.hs b/src/Opaleye/PGTypes.hs --- a/src/Opaleye/PGTypes.hs +++ b/src/Opaleye/PGTypes.hs @@ -10,6 +10,7 @@ import qualified Opaleye.Internal.HaskellDB.Sql.Default as HSD (quote) import qualified Data.CaseInsensitive as CI +import qualified Data.Aeson as Ae import qualified Data.Text as SText import qualified Data.Text.Lazy as LText import qualified Data.ByteString as SByteString @@ -127,6 +128,9 @@ pgLazyJSON :: LByteString.ByteString -> Column PGJson pgLazyJSON = pgJSON . IPT.lazyDecodeUtf8 +pgValueJSON :: Ae.ToJSON a => a -> Column PGJson +pgValueJSON = pgLazyJSON . Ae.encode + -- The jsonb data type was introduced in PostgreSQL version 9.4 -- JSONB values must be SQL string quoted -- @@ -140,3 +144,6 @@ pgLazyJSONB :: LByteString.ByteString -> Column PGJsonb pgLazyJSONB = pgJSONB . IPT.lazyDecodeUtf8 + +pgValueJSONB :: Ae.ToJSON a => a -> Column PGJsonb +pgValueJSONB = pgLazyJSONB . Ae.encode diff --git a/src/Opaleye/Table.hs b/src/Opaleye/Table.hs --- a/src/Opaleye/Table.hs +++ b/src/Opaleye/Table.hs @@ -3,7 +3,7 @@ module Opaleye.Table (module Opaleye.Table, View, Writer, - Table(Table), + Table(Table, TableWithSchema), TableProperties) where import Opaleye.Internal.Column (Column(Column))