opaleye 0.2 → 0.3
raw patch · 87 files changed
+3954/−2465 lines, 87 filesdep ~product-profunctorsdep ~profunctorsdep ~semigroups
Dependency ranges changed: product-profunctors, profunctors, semigroups, text, transformers
Files
- Doc/Tutorial/Main.hs +3/−2
- Doc/Tutorial/TutorialAdvanced.lhs +76/−0
- Doc/Tutorial/TutorialBasic.lhs +830/−0
- Doc/Tutorial/TutorialManipulation.lhs +120/−0
- Doc/UPGRADING.md +104/−0
- Opaleye/Aggregate.hs +0/−40
- Opaleye/Binary.hs +0/−29
- Opaleye/Column.hs +0/−29
- Opaleye/Distinct.hs +0/−13
- Opaleye/Internal/Aggregate.hs +0/−67
- Opaleye/Internal/Binary.hs +0/−55
- Opaleye/Internal/Column.hs +0/−65
- Opaleye/Internal/Distinct.hs +0/−44
- Opaleye/Internal/HaskellDB/PrimQuery.hs +0/−61
- Opaleye/Internal/HaskellDB/Query.hs +0/−26
- Opaleye/Internal/HaskellDB/Sql.hs +0/−61
- Opaleye/Internal/HaskellDB/Sql/Default.hs +0/−190
- Opaleye/Internal/HaskellDB/Sql/Generate.hs +0/−21
- Opaleye/Internal/HaskellDB/Sql/Print.hs +0/−103
- Opaleye/Internal/Helpers.hs +0/−16
- Opaleye/Internal/Join.hs +0/−40
- Opaleye/Internal/Optimize.hs +0/−31
- Opaleye/Internal/Order.hs +0/−47
- Opaleye/Internal/PackMap.hs +0/−102
- Opaleye/Internal/PrimQuery.hs +0/−62
- Opaleye/Internal/Print.hs +0/−115
- Opaleye/Internal/QueryArr.hs +0/−67
- Opaleye/Internal/RunQuery.hs +0/−98
- Opaleye/Internal/Sql.hs +0/−155
- Opaleye/Internal/Table.hs +0/−110
- Opaleye/Internal/TableMaker.hs +0/−85
- Opaleye/Internal/Tag.hs +0/−18
- Opaleye/Internal/Unpackspec.hs +0/−51
- Opaleye/Internal/Values.hs +0/−98
- Opaleye/Join.hs +0/−43
- Opaleye/Manipulation.hs +0/−118
- Opaleye/Operators.hs +0/−48
- Opaleye/Order.hs +0/−35
- Opaleye/PGTypes.hs +0/−53
- Opaleye/QueryArr.hs +0/−9
- Opaleye/RunQuery.hs +0/−48
- Opaleye/Sql.hs +0/−36
- Opaleye/Table.hs +0/−43
- Opaleye/Values.hs +0/−21
- README.md +72/−0
- TODO.md +28/−0
- Test/Test.hs +78/−90
- opaleye.cabal +26/−20
- src/Opaleye.hs +30/−0
- src/Opaleye/Aggregate.hs +53/−0
- src/Opaleye/Binary.hs +44/−0
- src/Opaleye/Column.hs +50/−0
- src/Opaleye/Distinct.hs +26/−0
- src/Opaleye/Internal/Aggregate.hs +63/−0
- src/Opaleye/Internal/Binary.hs +55/−0
- src/Opaleye/Internal/Column.hs +59/−0
- src/Opaleye/Internal/Distinct.hs +44/−0
- src/Opaleye/Internal/HaskellDB/PrimQuery.hs +71/−0
- src/Opaleye/Internal/HaskellDB/Sql.hs +56/−0
- src/Opaleye/Internal/HaskellDB/Sql/Default.hs +197/−0
- src/Opaleye/Internal/HaskellDB/Sql/Generate.hs +21/−0
- src/Opaleye/Internal/HaskellDB/Sql/Print.hs +106/−0
- src/Opaleye/Internal/Helpers.hs +16/−0
- src/Opaleye/Internal/Join.hs +40/−0
- src/Opaleye/Internal/Optimize.hs +31/−0
- src/Opaleye/Internal/Order.hs +47/−0
- src/Opaleye/Internal/PackMap.hs +102/−0
- src/Opaleye/Internal/PrimQuery.hs +65/−0
- src/Opaleye/Internal/Print.hs +114/−0
- src/Opaleye/Internal/QueryArr.hs +67/−0
- src/Opaleye/Internal/RunQuery.hs +127/−0
- src/Opaleye/Internal/Sql.hs +169/−0
- src/Opaleye/Internal/Table.hs +135/−0
- src/Opaleye/Internal/TableMaker.hs +86/−0
- src/Opaleye/Internal/Tag.hs +15/−0
- src/Opaleye/Internal/Unpackspec.hs +51/−0
- src/Opaleye/Internal/Values.hs +99/−0
- src/Opaleye/Join.hs +52/−0
- src/Opaleye/Manipulation.hs +120/−0
- src/Opaleye/Operators.hs +71/−0
- src/Opaleye/Order.hs +35/−0
- src/Opaleye/PGTypes.hs +93/−0
- src/Opaleye/QueryArr.hs +9/−0
- src/Opaleye/RunQuery.hs +63/−0
- src/Opaleye/Sql.hs +47/−0
- src/Opaleye/Table.hs +55/−0
- src/Opaleye/Values.hs +33/−0
Doc/Tutorial/Main.hs view
@@ -1,5 +1,6 @@-import TutorialBasic-import TutorialManipulation+import TutorialBasic ()+import TutorialManipulation ()+import TutorialAdvanced () main :: IO () main = return ()
+ Doc/Tutorial/TutorialAdvanced.lhs view
@@ -0,0 +1,76 @@+> {-# LANGUAGE FlexibleContexts #-}+>+> module TutorialAdvanced where+>+> import Prelude hiding (sum)+>+> import Opaleye.QueryArr (Query)+> import Opaleye.Column (Column)+> import Opaleye.Table (Table(Table), required, queryTable)+> import Opaleye.PGTypes (PGText, PGInt4)+> import qualified Opaleye.Aggregate as A+> import Opaleye.Aggregate (Aggregator, aggregate)+>+> import qualified Opaleye.Sql as Sql+> import qualified Opaleye.Internal.Unpackspec as U+>+> import Data.Profunctor.Product.Default (Default)+> import Data.Profunctor (dimap)+> import Data.Profunctor.Product ((***!), p2)+++Combining Aggregators+=====================++Opaleye allows you to straightforwardly combine aggregators to create+new aggregators in a way that is inconvenient to do directly in+Postgres.++We can define an aggregator to calculate the range of a group, that is+the difference between its maximum and minimum. Although we can write+this easily in SQL as `MAX(column) - MIN(column)`, Opaleye has the+advantage of treating `range` as a first-class value able to be passed+around between functions and manipulated at will.++> range :: Aggregator (Column PGInt4) (Column PGInt4)+> range = dimap (\x -> (x, x)) (uncurry (-)) (A.max ***! A.min)++We can test it on a person table which contains rows containing+people's names along with the age of their children.++> personTable :: Table (Column PGText, Column PGInt4)+> (Column PGText, Column PGInt4)+> personTable = Table "personTable" (p2 ( required "name"+> , required "child_age" ))++> rangeOfChildrensAges :: Query (Column PGText, Column PGInt4)+> rangeOfChildrensAges = aggregate (p2 (A.groupBy, range)) (queryTable personTable)+++TutorialAdvanced> printSql rangeOfChildrensAges +SELECT result0_2 as result1,+ (result1_2) - (result2_2) as result2+FROM (SELECT *+ FROM (SELECT name0_1 as result0_2,+ MAX(child_age1_1) as result1_2,+ MIN(child_age1_1) as result2_2+ FROM (SELECT *+ FROM (SELECT name as name0_1,+ child_age as child_age1_1+ FROM personTable as T1) as T1) as T1+ GROUP BY name0_1) as T1) as T1+++Idealised SQL:++SELECT name,+ MAX(child_age) - MIN(child_age)+FROM personTable+GROUP BY name+++Helper function+===============++> printSql :: Default U.Unpackspec a a => Query a -> IO ()+> printSql = putStrLn . Sql.showSqlForPostgres
+ Doc/Tutorial/TutorialBasic.lhs view
@@ -0,0 +1,830 @@+> {-# LANGUAGE Arrows #-}+> {-# LANGUAGE FlexibleContexts #-}+> {-# LANGUAGE FlexibleInstances #-}+> {-# LANGUAGE MultiParamTypeClasses #-}+> {-# LANGUAGE TemplateHaskell #-}+>+> module TutorialBasic where+>+> import Prelude hiding (sum)+>+> import Opaleye (Column, Nullable, matchNullable, isNull,+> Table(Table), required, queryTable,+> Query, QueryArr, restrict, (.==), (.<=), (.&&), (.<),+> (.++), ifThenElse, pgString, aggregate, groupBy,+> count, avg, sum, leftJoin, runQuery,+> showSqlForPostgres, Unpackspec,+> PGInt4, PGInt8, PGText, PGDate, PGFloat8, PGBool)+>+> import Data.Profunctor.Product (p2, p3)+> import Data.Profunctor.Product.Default (Default)+> import Data.Profunctor.Product.TH (makeAdaptorAndInstance)+> import Data.Time.Calendar (Day)+>+> import Control.Arrow (returnA, (<<<))+>+> import qualified Database.PostgreSQL.Simple as PGS++Introduction+============++In this example file I'll give you a brief introduction to the Opaleye+relational query EDSL. I'll show you how to define tables in Opaleye;+use them to generate selects, joins and filters; use the API of+Opaleye to make your queries more composable; and finally run the+queries on Postgres.++Schema+======++Opaleye assumes that a Postgres database already exists. Currently+there is no support for creating databases or tables, though these+features may be added later according to demand.++A table is defined with the `Table` constructor. The syntax is+simple. You specify the types of the columns, the name of the table+and the names of the columns in the underlying database, and whether+the columns are required or optional.++(Note: This simple syntax is supported by an extra combinator that+describes the shape of the container that you are storing the columns+in. In the first example we are using a tuple of size 3 and the+combinator is called `p3`. We'll see examples of others later.)++The `Table` type constructor has two arguments. The first one tells+us what columns we can write to the table and the second what columns+we can read from the table. In this document we will always make all+columns required, so the write and read types will be the same. All+`Table` types will have the same type argument repeated twice. In the+manipulation tutorial you can see an example of when they might differ.++> personTable :: Table (Column PGText, Column PGInt4, Column PGText)+> (Column PGText, Column PGInt4, Column PGText)+> personTable = Table "personTable" (p3 ( required "name"+> , required "age"+> , required "address" ))++To query a table we use `queryTable`.++(Here and in a few other places in Opaleye there is some typeclass+magic going on behind the scenes. However, you never *have* to use+typeclasses. All the magic that typeclasses do is also available by+explicitly passing in the "typeclass dictionary". For this example+file we will always use the typeclass versions because they are+simpler to read and the typeclass magic is essentially invisible.)++> personQuery :: Query (Column PGText, Column PGInt4, Column PGText)+> personQuery = queryTable personTable++A `Query` corresponds to an SQL SELECT that we can run. Here is the+SQL generated for `personQuery`.++ghci> printSql personQuery+SELECT name0_1 as result1,+ age1_1 as result2,+ address2_1 as result3+FROM (SELECT *+ FROM (SELECT name as name0_1,+ age as age1_1,+ address as address2_1+ FROM personTable as T1) as T1) as T1++This SQL is functionally equivalent to the following "idealized" SQL.+In this document every example of SQL generated by Opaleye will be+followed by an "idealized" equivalent version. This will give you+some idea of how readable the SQL generated by Opaleye is. Eventually+Opaleye should generate SQL closer to the "idealized" version, but+that is an ongoing project. Since Postgres has a sensible query+optimization engine there should be little difference in performance+between Opaleye's version and the ideal. Please submit any+differences encountered in practice as an Opaleye bug.++SELECT name,+ age+ address+FROM personTable++(`printSQL` is just a convenient utility function for the purposes of+this example file. See below for its definition.)+++Record types+------------++Opaleye can use user defined types such as record types in queries.++It will save you a lot of headaches if you define your data types to+be polymorphic in all their fields. If you want to use concrete types+in particular places, as you almost always will, you can use type+synonyms. For example:++> data Birthday' a b = Birthday { bdName :: a, bdDay :: b }+> type Birthday = Birthday' String Day+> type BirthdayColumn = Birthday' (Column PGText) (Column PGDate)++To get user defined types to work with the typeclass magic they must+have instances defined for them. The instances are derivable with+Template Haskell.++> $(makeAdaptorAndInstance "pBirthday" ''Birthday')++Then we can use 'Table' to make a table on our record type in exactly+the same way as before.++> birthdayTable :: Table BirthdayColumn BirthdayColumn+> birthdayTable = Table "birthdayTable"+> (pBirthday Birthday { bdName = required "name"+> , bdDay = required "birthday" })+>+> birthdayQuery :: Query BirthdayColumn+> birthdayQuery = queryTable birthdayTable++ghci> printSql birthdayQuery+SELECT name0_1 as result1,+ birthday1_1 as result2+FROM (SELECT *+ FROM (SELECT name as name0_1,+ birthday as birthday1_1+ FROM birthdayTable as T1) as T1) as T1++Idealized SQL:++SELECT name,+ birthday+FROM birthdayTable+++Projection+==========++"Projection" means discarding some of the columns of our query, for+example we might want to discard the "address" column of our+`personQuery`.++Projection gives us our first example of using "arrow notation" to+write Opaleye queries. Arrow notation is essentially a restricted+version of "do notation". Arrow notation allows you to write arrow+computations, and do notation allows you to write monadic+computations.++Here we run the `personQuery` passing in () to signify "zero+arguments". We pattern match on the results and return only the+columns we are interested in.++> nameAge :: Query (Column PGText, Column PGInt4)+> nameAge = proc () -> do+> (name, age, _) <- personQuery -< ()+> returnA -< (name, age)++ghci> printSql nameAge+SELECT name0_1 as result1,+ age1_1 as result2+FROM (SELECT *+ FROM (SELECT name as name0_1,+ age as age1_1,+ address as address2_1+ FROM personTable as T1) as T1) as T1++Idealized SQL:++SELECT name,+ age+FROM personTable++Product+=======++"Product" means taking the Cartesian product of two queries. This is+simple in arrow notation. Here we take the product of `personQuery`+and `birthdayQuery`.++> personBirthdayProduct ::+> Query ((Column PGText, Column PGInt4, Column PGText), BirthdayColumn)+> personBirthdayProduct = proc () -> do+> personRow <- personQuery -< ()+> birthdayRow <- birthdayQuery -< ()+>+> returnA -< (personRow, birthdayRow)++ghci> printSql personBirthdayProduct+SELECT name0_1 as result1,+ age1_1 as result2,+ address2_1 as result3,+ name0_2 as result4,+ birthday1_2 as result5+FROM (SELECT *+ FROM (SELECT name as name0_1,+ age as age1_1,+ address as address2_1+ FROM personTable as T1) as T1,+ (SELECT name as name0_2,+ birthday as birthday1_2+ FROM birthdayTable as T1) as T2) as T1++Idealized SQL:++SELECT name0,+ age0,+ address0,+ name1,+ birthday1+FROM (SELECT name as name0,+ age as age0,+ address as address0+ FROM personTable as T1),+ (SELECT name as name1,+ birthday as birthday1+ FROM birthdayTable as T1)+++Restriction+===========++"Restriction" means restricting the rows of the result of a query to+only those where some condition holds.++We can restrict `personQuery` to the rows where the person is up to 18+years old.++> youngPeople :: Query (Column PGText, Column PGInt4, Column PGText)+> youngPeople = proc () -> do+> row@(_, age, _) <- personQuery -< ()+> restrict -< age .<= 18+>+> returnA -< row++ghci> printSql youngPeople+SELECT name0_1 as result1,+ age1_1 as result2,+ address2_1 as result3+FROM (SELECT *+ FROM (SELECT name as name0_1,+ age as age1_1,+ address as address2_1+ FROM personTable as T1) as T1+ WHERE ((age1_1) <= 18)) as T1++Idealized SQL:++SELECT name,+ age,+ address+FROM personTable+WHERE age <= 18+++We can use a variety of operators to form more complex restriction+conditions.++> twentiesAtAddress :: Query (Column PGText, Column PGInt4, Column PGText)+> twentiesAtAddress = proc () -> do+> row@(_, age, address) <- personQuery -< ()+>+> restrict -< (20 .<= age) .&& (age .< 30)+> restrict -< address .== pgString "1 My Street, My Town"+>+> returnA -< row++SELECT name0_1 as result1,+ age1_1 as result2,+ address2_1 as result3+FROM (SELECT *+ FROM (SELECT name as name0_1,+ age as age1_1,+ address as address2_1+ FROM personTable as T1) as T1+ WHERE ((address2_1) = '1 My Street, My Town') AND ((20 <= (age1_1))+ AND ((age1_1) < 30))) as T1++Idealized SQL:++SELECT name,+ age,+ address+FROM personTable+WHERE address = '1 My Street, My Town'+AND 20 <= age+AND age < 30+++Inner join+----------++A Product followed by a restriction is sometimes called a "join" or+"inner join" in SQL terminology. The following query is an example of+such.++> personAndBirthday ::+> Query (Column PGText, Column PGInt4, Column PGText, Column PGDate)+> personAndBirthday = proc () -> do+> (name, age, address) <- personQuery -< ()+> birthday <- birthdayQuery -< ()+>+> restrict -< name .== bdName birthday+>+> returnA -< (name, age, address, bdDay birthday)+++ghci> printSql personAndBirthday+SELECT name0_1 as result1,+ age1_1 as result2,+ address2_1 as result3,+ birthday1_2 as result4+FROM (SELECT *+ FROM (SELECT name as name0_1,+ age as age1_1,+ address as address2_1+ FROM personTable as T1) as T1,+ (SELECT name as name0_2,+ birthday as birthday1_2+ FROM birthdayTable as T1) as T2+ WHERE ((name0_1) = (name0_2))) as T1++Idealized SQL:++SELECT name0,+ age0,+ address0,+ name1,+ birthday1+FROM (SELECT name as name0,+ age as age0,+ address as address0+ FROM personTable as T1),+ (SELECT name as name1,+ birthday as birthday1+ FROM birthdayTable as T1)+WHERE name0 == name1+++Nullability+===========++NULLs in SQL have been the source of a lot of complaints, but as+Haskell programmers we know that there is nothing wrong with+nullability as long is it is reflected in the type system. Nullable+columns are indicated with the `Nullable` type constructor.++For example, suppose we have an employee table which records the name+of each employee and the name of their boss. If their boss is+recorded as NULL then that means they have no boss!++> employeeTable :: Table (Column PGText, Column (Nullable PGText))+> (Column PGText, Column (Nullable PGText))+> employeeTable = Table "employeeTable" (p2 ( required "name"+> , required "boss" ))++We can write a query that returns as string indicating for each+employee whether they have a boss.++> hasBoss :: Query (Column PGText)+> hasBoss = proc () -> do+> (name, nullableBoss) <- queryTable employeeTable -< ()+>+> let aOrNo = ifThenElse (isNull nullableBoss) (pgString "no") (pgString "a")+>+> returnA -< name .++ pgString " has " .++ aOrNo .++ pgString " boss"++SELECT (((name0_1) || ' has ')+ || (CASE WHEN boss1_1 IS NULL THEN 'no' ELSE 'a' END))+ || ' boss' as result1+FROM (SELECT *+ FROM (SELECT name as name0_1,+ boss as boss1_1+ FROM employeeTable as T1) as T1) as T1++Idealized SQL:++SELECT name || ' has '+ || CASE WHEN boss IS NULL THEN 'no' ELSE 'a' END || ' boss'+FROM employeeTable++But we can do much more than just check for NULL of course. We can+write a query arrow to produce a string describing each employee's+status along with the name of their boss, if any. The combinator+`matchNullable` checks whether `nullableBoss` is NULL. If so it+returns its first argument. If not it passes the non-NULL value to+the function that is the second argument.++> bossQuery :: QueryArr (Column PGText, Column (Nullable PGText)) (Column PGText)+> bossQuery = proc (name, nullableBoss) -> do+> returnA -< matchNullable (name .++ pgString " has no boss")+> (\boss -> pgString "The boss of " .++ name+> .++ pgString " is " .++ boss)+> nullableBoss++Note that `matchNullable` corresponds to Haskell's++ maybe :: b -> (a -> b) -> Maybe a -> b++and in pure Haskell the same computation could be expressed as++> bossHaskell :: (String, Maybe String) -> String+> bossHaskell (name, nullableBoss) = maybe (name ++ " has no boss")+> (\boss -> "The boss of " ++ name+> ++ " is " ++ boss)+> nullableBoss++Then we get the following SQL.++ghci> printSql (bossQuery <<< queryTable employeeTable)+SELECT CASE WHEN boss1_1 IS NULL THEN (name0_1) || ' has no boss'+ ELSE (('The boss of ' || (name0_1)) || ' is ') || (boss1_1) END as result1+FROM (SELECT *+ FROM (SELECT name as name0_1,+ boss as boss1_1+ FROM employeeTable as T1) as T1) as T1++Idealized SQL:++SELECT CASE WHEN boss IS NULL+ THEN name0_1 || ' has no boss'+ ELSE 'The boss of ' || name || ' is ' || boss+ END+FROM employeeTable+++Composability+=============++Rewriting `twentiesAtAddress` will allow us to get our first glimpse+of the enormous composability that Opaleye offers.++We can factor out some parts of the 'twentiesAtAddress' query. For+example we can pull out the restriction to one's age being "in the+twenties" and the restriction to the one's address being "1 My Street,+My Town".++The types are of the form `QueryArr a ()`. This means that they read+columns of type `a` but do not return any columns. (Note: `Query` is+just a synonym for `QueryArr ()` which means that it is a `QueryArr`+that does not read any columns.)++> restrictIsTwenties :: QueryArr (Column PGInt4) ()+> restrictIsTwenties = proc age -> do+> restrict -< (20 .<= age) .&& (age .< 30)+>+> restrictAddressIs1MyStreet :: QueryArr (Column PGText) ()+> restrictAddressIs1MyStreet = proc address -> do+> restrict -< address .== pgString "1 My Street, My Town"++We can't generate "the SQL of" these combinators. They are not+`Query`s so they don't have any SQL! (This corresponds to the+observation that in Haskell typically values can be "shown", but+functions cannot be "shown".) Instead we use them to reimplement+`twentiesAtAddress` in a more neatly-factored way.++> twentiesAtAddress' :: Query (Column PGText, Column PGInt4, Column PGText)+> twentiesAtAddress' = proc () -> do+> row@(_, age, address) <- personQuery -< ()+>+> restrictIsTwenties -< age+> restrictAddressIs1MyStreet -< address+>+> returnA -< row++The SQL generated is exactly the same as before++ghci> printSql twentiesAtAddress'+SELECT name0_1 as result1,+ age1_1 as result2,+ address2_1 as result3+FROM (SELECT *+ FROM (SELECT name as name0_1,+ age as age1_1,+ address as address2_1+ FROM personTable as T1) as T1+ WHERE ((address2_1) = '1 My Street, My Town') AND ((20 <= (age1_1))+ AND ((age1_1) < 30))) as T1+++Composability of joins+----------------------++We can perform a similar transformation for `personAndBirthday` by+pulling out a `QueryArr` which perform the mapping of a person's name+to their date of birth by looking up in `birthdayQuery`.++> birthdayOfPerson :: QueryArr (Column PGText) (Column PGDate)+> birthdayOfPerson = proc name -> do+> birthday <- birthdayQuery -< ()+>+> restrict -< name .== bdName birthday+>+> returnA -< bdDay birthday++We can then reimplement `personAndBirthday` as follows++> personAndBirthday' ::+> Query (Column PGText, Column PGInt4, Column PGText, Column PGDate)+> personAndBirthday' = proc () -> do+> (name, age, address) <- personQuery -< ()+> birthday <- birthdayOfPerson -< name+>+> returnA -< (name, age, address, birthday)++and it yields the same SQL as before.++ghci> printSql personAndBirthday'+SELECT name0_1 as result1,+ age1_1 as result2,+ address2_1 as result3,+ birthday1_2 as result4+FROM (SELECT *+ FROM (SELECT name as name0_1,+ age as age1_1,+ address as address2_1+ FROM personTable as T1) as T1,+ (SELECT name as name0_2,+ birthday as birthday1_2+ FROM birthdayTable as T1) as T2+ WHERE ((name0_1) = (name0_2))) as T1++++Aggregation+===========++Type safe aggregation is the jewel in the crown of Opaleye. Even SQL+generating APIs which are otherwise type safe often fall down when it+comes to aggregation. If you want to find holes in the type system of+an SQL generating language, aggregation is the best place to look! By+contrast, Opaleye aggregations always generate meaningful SQL.++By way of example, suppose we have a widget table which contains the+style, color, location, quantity and radius of widgets. We can model+this information with the following datatype.++> data Widget a b c d e = Widget { style :: a+> , color :: b+> , location :: c+> , quantity :: d+> , radius :: e }+>+> $(makeAdaptorAndInstance "pWidget" ''Widget)++For the purposes of this example the style, color and location will be+strings, but in practice they might have been a different data type.++> widgetTable :: Table (Widget (Column PGText) (Column PGText) (Column PGText)+> (Column PGInt4) (Column PGFloat8))+> (Widget (Column PGText) (Column PGText) (Column PGText)+> (Column PGInt4) (Column PGFloat8))+> widgetTable = Table "widgetTable"+> (pWidget Widget { style = required "style"+> , color = required "color"+> , location = required "location"+> , quantity = required "quantity"+> , radius = required "radius" })+++Say we want to group by the style and color of widgets, calculating+how many (possibly duplicated) locations there are, the total number+of such widgets and their average radius. `aggregateWidgets` shows us+how to do this.++> aggregateWidgets :: Query (Widget (Column PGText) (Column PGText) (Column PGInt8)+> (Column PGInt4) (Column PGFloat8))+> aggregateWidgets = aggregate (pWidget (Widget { style = groupBy+> , color = groupBy+> , location = count+> , quantity = sum+> , radius = avg }))+> (queryTable widgetTable)++The generated SQL is++ghci> printSql aggregateWidgets+SELECT result0_2 as result1,+ result1_2 as result2,+ result2_2 as result3,+ result3_2 as result4,+ result4_2 as result5+FROM (SELECT *+ FROM (SELECT style0_1 as result0_2,+ color1_1 as result1_2,+ COUNT(location2_1) as result2_2,+ SUM(quantity3_1) as result3_2,+ AVG(radius4_1) as result4_2+ FROM (SELECT *+ FROM (SELECT style as style0_1,+ color as color1_1,+ location as location2_1,+ quantity as quantity3_1,+ radius as radius4_1+ FROM widgetTable as T1) as T1) as T1+ GROUP BY style0_1,+ color1_1) as T1) as T1++Idealized SQL:++SELECT style,+ color,+ COUNT(location),+ SUM(quantity),+ AVG(radius)+FROM widgetTable+GROUP BY style, color++Note: In `widgetTable` and `aggregateWidgets` we see more explicit+uses of our Template Haskell derived code. We use the 'pWidget'+"adaptor" to specify how columns are aggregated. Note that this is+yet another example of avoiding a headache by keeping your datatype+fully polymorphic, because the 'count' aggregator changes a 'Wire+String' into a 'Wire Int64'.++Outer join+==========++Opaleye supports left joins. (Full outer joins and right joins are+left to be added as a simple starter project for a new Opaleye+contributer!)++Because left joins can change non-nullable columns into nullable+columns we have to make sure the type of the output supports+nullability. We introduce the following type synonym for this+purpose, which is just a notational convenience.++> type ColumnNullableBirthday = Birthday' (Column (Nullable PGText))+> (Column (Nullable PGDate))++A left join is expressed by specifying the two tables to join and the+join condition.++> personBirthdayLeftJoin :: Query ((Column PGText, Column PGInt4, Column PGText),+> ColumnNullableBirthday)+> personBirthdayLeftJoin = leftJoin personQuery birthdayQuery eqName+> where eqName ((name, _, _), birthdayRow) = name .== bdName birthdayRow++The generated SQL is++ghci> printSql personBirthdayLeftJoin+SELECT result1_0_3 as result1,+ result1_1_3 as result2,+ result1_2_3 as result3,+ result2_0_3 as result4,+ result2_1_3 as result5+FROM (SELECT *+ FROM (SELECT name0_1 as result1_0_3,+ age1_1 as result1_1_3,+ address2_1 as result1_2_3,+ name0_2 as result2_0_3,+ birthday1_2 as result2_1_3+ FROM+ (SELECT *+ FROM (SELECT name as name0_1,+ age as age1_1,+ address as address2_1+ FROM personTable as T1) as T1) as T1+ LEFT OUTER JOIN+ (SELECT *+ FROM (SELECT name as name0_2,+ birthday as birthday1_2+ FROM birthdayTable as T1) as T1) as T2+ ON+ (name0_1) = (name0_2)) as T1) as T1++Idealized SQL:++SELECT name0,+ age0,+ address0,+ name1,+ birthday1+FROM (SELECT name as name0,+ age as age0,+ address as address0+ FROM personTable) as T1+ LEFT OUTER JOIN+ (SELECT name as name1,+ birthday as birthday1+ FROM birthdayTable) as T1+ON name0 = name1++++Newtypes+========++In Haskell, newtypes are a great way of getting additional typesafety.+For example, the ID of a warehouse may be an integer, but instead of+representing it as a naked `Int` we wrap it in a `WarehouseId` newtype+to guard against meaninglessly mixing it with other `Int`s. We can do+something similar in Opaleye.++For this example, a warehouse has an integer ID, a location, and holds+and integer quantity of goods.++> data Warehouse' a b c = Warehouse { wId :: a+> , wLocation :: b+> , wNumGoods :: c }+>+> $(makeAdaptorAndInstance "pWarehouse" ''Warehouse')++We could represent the integer ID in Opaleye as a `PGInt4`++> type BadWarehouseColumn = Warehouse' (Column PGInt4)+> (Column PGText)+> (Column PGInt4)+>+> badWarehouseTable :: Table BadWarehouseColumn BadWarehouseColumn+> badWarehouseTable = Table "warehouse_table"+> (pWarehouse Warehouse { wId = required "id"+> , wLocation = required "location"+> , wNumGoods = required "num_goods" })++but that would expose us to the following sorts of errors, where we+can meaninglessly relate the warehouse ID with the quantity of goods+it holds.++> badComparison :: BadWarehouseColumn -> Column PGBool+> badComparison w = wId w .== wNumGoods w++On the other hand we can make a newtype for the warehouse ID++> -- TODO: Since the `makeAdaptorAndInstance` Template Haskell is+> -- poorly written we have to make this `data` rather than `newtype` but+> -- this will be fixed in a later version.+> data WarehouseId' a = WarehouseId a+> $(makeAdaptorAndInstance "pWarehouseId" ''WarehouseId')+>+> type WarehouseIdColumn = WarehouseId' (Column PGInt4)+>+> type GoodWarehouseColumn = Warehouse' WarehouseIdColumn+> (Column PGText)+> (Column PGInt4)+>+> goodWarehouseTable :: Table GoodWarehouseColumn GoodWarehouseColumn+> goodWarehouseTable = Table "warehouse_table"+> (pWarehouse Warehouse { wId = pWarehouseId (WarehouseId (required "id"))+> , wLocation = required "location"+> , wNumGoods = required "num_goods" })++Now the comparison will not pass the type checker.++> -- forbiddenComparison :: GoodWarehouseColumn -> Column PGBool+> -- forbiddenComparison w = wId w .== wNumGoods w+> --+> -- => Couldn't match type `WarehouseId' (Column PGInt4)' with `Column PGInt4'+++Running queries on Postgres+===========================+++Opaleye provides simple facilities for running queries on Postgres.+`runQuery` is a typeclass polymorphic function that effectively has+the following type++> -- runQuery :: Database.PostgreSQL.Simple.Connection+> -- -> Query columns -> IO [haskells]++It converts a "record" of Opaleye columns to a list of "records" of+Haskell values. Because this particular formulation uses typeclasses+please put type signatures on everything in sight to minimize the+number of confusing error messages!++For example, for the 'twentiesAtAddress' query `runQuery` would have+the following type:++> runTwentiesQuery :: PGS.Connection+> -> Query (Column PGText, Column PGInt4, Column PGText)+> -> IO [(String, Int, String)]+> runTwentiesQuery = runQuery++Note that nullable columns are indicated with the Nullable type+constructor, and these are converted to Maybe when executed. If we+have a table with a nullable column then Nullable columns turn into+Maybes. We could run the query `queryTable employeeTable` like this.++> runEmployeesQuery :: PGS.Connection+> -> Query (Column PGText, Column (Nullable PGText))+> -> IO [(String, Maybe String)]+> runEmployeesQuery = runQuery++Newtypes are taken care of automatically by the typeclass instance+that was generated by `makeAdaptorAndInstance`. A `WarehouseId'+(Column PGInt4)` becomes a `WarehouseId' Int` when the query is run.+We could run the query `queryTable goodWarehouseTable` like this.++> type WarehouseId = WarehouseId' Int+> type GoodWarehouse = Warehouse' WarehouseId String Int+>+> runWarehouseQuery :: PGS.Connection+> -> Query GoodWarehouseColumn+> -> IO [GoodWarehouse]+> runWarehouseQuery = runQuery+++Conclusion+==========++There ends the Opaleye introductions module. Please send me your questions!++Utilities+=========++This is a little utility function to help with printing generated SQL.++> printSql :: Default Unpackspec a a => Query a -> IO ()+> printSql = putStrLn . showSqlForPostgres
+ Doc/Tutorial/TutorialManipulation.lhs view
@@ -0,0 +1,120 @@+> module TutorialManipulation where+>+> import Prelude hiding (sum)+>+> import Opaleye (Column, Table(Table),+> required, optional, (.==), (.<),+> arrangeDeleteSql, arrangeInsertSql,+> arrangeUpdateSql, arrangeInsertReturningSql,+> PGInt4, PGFloat8)+>+> import Data.Profunctor.Product (p3)+> import Data.Profunctor.Product.Default (Default, def)+++Manipulation+============++Manipulation means changing the data in the database. This means SQL+DELETE, INSERT and UPDATE.++To demonstrate manipulation in Opaleye we will need a table to perform+our manipulation on. It will have three columns: an integer-valued+"id" column (assumed to be an auto-incrementing field) and two+double-valued required fields. The `Table` type constructor has two+type arguments. The first one is the type of writes to the table, and+the second is the type of reads from the table. Notice that the "id"+column was defined as optional (for writes) so in the type of writes+it is wrapped in a Maybe. That means we don't necessarily need to+specify it when writing to the table. The database will automatically+fill in a value for us.++> table :: Table (Maybe (Column PGInt4), Column PGFloat8, Column PGFloat8)+> (Column PGInt4, Column PGFloat8, Column PGFloat8)+> table = Table "tablename" (p3 (optional "id", required "x", required "y"))++To perform a delete we provide an expression from our read type to+`Column Bool`. All rows for which the expression is true are deleted.++> delete :: String+> delete = arrangeDeleteSql table (\(_, x, y) -> x .< y)++ghci> putStrLn delete+DELETE FROM tablename+WHERE ((x) < (y))+++To insert we provide a row with the write type. Optional columns can+be omitted by providing `Nothing` instead.++> insertNothing :: String+> insertNothing = arrangeInsertSql table (Nothing, 2, 3)++ghci> putStrLn insertNothing+INSERT INTO tablename (x,+ y)+VALUES (2.0,+ 3.0)+++If we really want to specify an optional column we can use `Just`.++> insertJust :: String+> insertJust = arrangeInsertSql table (Just 1, 2, 3)++ghci> putStrLn insertJust+INSERT INTO tablename (id,+ x,+ y)+VALUES (1,+ 2.0,+ 3.0)+++An update takes an update function from the read type to the write+type, and a condition given by a function from the read type to+`Column Bool`. All rows that satisfy the condition are updated+according to the update function.++> update :: String+> update = arrangeUpdateSql table (\(_, x, y) -> (Nothing, x + y, x - y))+> (\(id_, _, _) -> id_ .== 5)++ghci> putStrLn update+UPDATE tablename+SET x = (x) + (y),+ y = (x) - (y)+WHERE ((id) = 5)+++Sometimes when we insert a row with an automatically generated field+we want the database to return the new field value to us so we can use+it in future queries. SQL supports that via INSERT RETURNING and+Opaleye supports it also.++> insertReturning :: String+> insertReturning = arrangeInsertReturningSql def table (Nothing, 4, 5)+> (\(id_, _, _) -> id_)++ghci> putStrLn insertReturning+INSERT INTO tablename (x,+ y)+VALUES (4.0,+ 5.0)+RETURNING id+++Running the queries+===================++This tutorial has only shown you how to generate the SQL string for+manipulation queries. In practice you actually want to run them! To+run them you should use `runInsert` instead of `arrangeInsertSql`,+`runDelete` instead of `arrangeDeleteSql`, etc..+++Comments+========++Opaleye does not currently support inserting more than one row at+once, or SELECT-valued INSERT or UPDATE.
+ Doc/UPGRADING.md view
@@ -0,0 +1,104 @@+# Changes since version 0++This document pertains to changes between various old pre-release+versions of Opaleye and the first release to Hackage. It is+irrelevant to you if you have only used Opaleye since its first+Hackage release.++## Changes visible in the API++### `Wire` becomes `Column`. `ExprArr` is gone.++The most important user-visible difference between Opaleye 0 and+Opaleye 1 is that `Wire` is now called `Column`. This is not just a+cosmetic change. `Column` contains an entire SQL expression rather+than just a column reference. That is, it contains what used to be+`ExprArr`. The benefit is that manipulating SQL expressions no longer+needs the hassle of `ExprArr`. For example, numerical operations can+be expressed succinctly++ calculation = proc () -> do+ (a, b, c) <- table -< ()+ returnA -< a + ifThenElse (b .== c) (b * c) (a / 2)++### Namespace changes++The namespace has changed from Karamaan.Opaleye to Opaleye. Many of+the version 0 modules were very cluttered with deprecated names. They+have been cleaned and tidied.++### Tables have type parameters for writing and reading++Tables now have two type parameters. One indicates how to use it for+writing, the other for reading.++### `Nullable` is no longer a synonym for `Maybe`++`Nullable` is now a new type independent of `Maybe`. `runQuery` still+converts it to `Maybe` but Opaleye-side code should use `Nullable`+instead of `Maybe`.++### `ShowConstant` doesn't exist++The `ShowConstant` typeclass for lifting Haskell values into Opaleye+does not exist anymore. Instead there is a `PGTypes` module with+individual functions for lifting values. If after due consideration+it seems like the typeclass was needed after all it can be added back+in.++## Internal changes++### SQL generation++Opaleye 1 uses less of HaskellDB's SQL generator. HaskellDB's+optimizer is extremely buggy and its SQL generator does not support+`OUTER JOIN` or `VALUES`. It would have been more difficult to work+around or patch HaskellDB than simply to write a new SQL generator for+Opaleye, so we did the latter.++### `PackMap`++Many or most of the product profunctors in use in Opaleye 0 have been+unified as values of specific type called `PackMap` which seems very+similar to a "traversal" from `Control.Lens`. This cuts down on a lot+of boilerplate and allows unification of concepts and functionality.++## Converting from version 0++Please note that although almost all of Opaleye 0's functionality is+now present in Opaleye 1, we are still missing the implementation of+many operators and instances. This is a very small amount of work and+would be a good starter project. Patches for this are welcome. For+example++* `RunQuery` is fully implemented but most of the `QueryRunner`+ instances just need to be written down.+* Support for numeric, boolean, etc. operators is fully+ implemented but many of them still need to be written down.+* Support for binary set operations and `OUTER JOIN`s is fully+ implemented but the definitions of `UNION`, `INTERSECT`,+ `INTERSECT ALL`, `RIGHT JOIN`, `FULL OUTER JOIN` etc. still need+ to be written down.++Opaleye 0 and Opaleye 1 can exist together in the same codebase+because they have different package names and different module+namespaces. However, I would recommend converting to Opaleye 1 and+writing all new code with Opaleye 1 because it is easier to use.++Converting from Opaleye 0 to Opaleye 1 might be smoother if you+provide the following synonyms during the transition.++ type Wire = Column+ type ExprArr = (->)++ toQueryArrDef :: ExprArr a b -> QueryArr a b+ toQueryArrDef = arr++Information about how well this works in practice would be gratefully+received.++You will probably find that many identifiers have changed,+particularly fully qualified identifiers. Theoretically a transition+package could be provided that maps from the old names to the new+names, but I suspect this is likely to be more work than just changing+all the old uses by hand.
− Opaleye/Aggregate.hs
@@ -1,40 +0,0 @@--- | Perform aggregations on query results.-module Opaleye.Aggregate (module Opaleye.Aggregate, Aggregator) where--import qualified Opaleye.Internal.Aggregate as A-import Opaleye.Internal.Aggregate (Aggregator)-import Opaleye.QueryArr (Query)-import qualified Opaleye.Internal.QueryArr as Q-import qualified Opaleye.Column as C--import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ--import GHC.Int (Int64)---- This page of Postgres documentation tell us what aggregate--- functions are available------ http://www.postgresql.org/docs/9.3/static/functions-aggregate.html---- | Group the aggregation by equality on the input to 'groupBy'.-groupBy :: Aggregator (C.Column a) (C.Column a)-groupBy = A.makeAggr' Nothing---- | Sum all rows in a group.-sum :: Aggregator (C.Column a) (C.Column a)-sum = A.makeAggr HPQ.AggrSum---- | Count the number of non-null rows in a group.-count :: Aggregator (C.Column a) (C.Column Int64)-count = A.makeAggr HPQ.AggrCount---- | Average of a group-avg :: Aggregator (C.Column Double) (C.Column Double)-avg = A.makeAggr HPQ.AggrAvg--{-|-Given a 'Query' producing rows of type @a@ and an 'Aggregator' accepting rows of-type @a@, apply the aggregator to the results of the query.--}-aggregate :: Aggregator a b -> Query a -> Query b-aggregate agg q = Q.simpleQueryArr (A.aggregateU agg . Q.runSimpleQueryArr q)
− Opaleye/Binary.hs
@@ -1,29 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts #-}--module Opaleye.Binary where--import Opaleye.QueryArr (Query)-import qualified Opaleye.Internal.QueryArr as Q-import qualified Opaleye.Internal.Binary as B-import qualified Opaleye.Internal.Tag as T-import qualified Opaleye.Internal.PrimQuery as PQ-import qualified Opaleye.Internal.PackMap as PM--import Data.Profunctor.Product.Default (Default, def)--unionAll :: Default B.Binaryspec columns columns =>- Query columns -> Query columns -> Query columns-unionAll = unionAllExplicit def--unionAllExplicit :: B.Binaryspec columns columns'- -> Query columns -> Query columns -> Query columns'-unionAllExplicit binaryspec q1 q2 = Q.simpleQueryArr q where- q ((), startTag) = (newColumns, newPrimQuery, T.next endTag)- where (columns1, primQuery1, midTag) = Q.runSimpleQueryArr q1 ((), startTag)- (columns2, primQuery2, endTag) = Q.runSimpleQueryArr q2 ((), midTag)-- (newColumns, pes) =- PM.run (B.runBinaryspec binaryspec (B.extractBinaryFields endTag)- (columns1, columns2))-- newPrimQuery = PQ.Binary PQ.UnionAll pes (primQuery1, primQuery2)
− Opaleye/Column.hs
@@ -1,29 +0,0 @@-module Opaleye.Column (module Opaleye.Column,- Column,- Nullable,- unsafeCoerce) where--import Opaleye.Internal.Column (Column, Nullable, unsafeCoerce)-import qualified Opaleye.Internal.Column as C--import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ---- | A NULL of any type-null :: Column (Nullable a)-null = unsafeCoerce (C.Column (HPQ.ConstExpr HPQ.NullLit))--isNull :: Column (Nullable a) -> Column Bool-isNull = C.unOp HPQ.OpIsNull---- | The Opaleye equivalent of the maybe function-matchNullable :: Column b -> (Column a -> Column b) -> Column (Nullable a)- -> Column b-matchNullable replacement f x = C.ifThenElse (isNull x) replacement- (f (unsafeCoerce x))---- | The Opaleye equivalent of the fromMaybe function-fromNullable :: Column a -> Column (Nullable a) -> Column a-fromNullable = flip matchNullable id--toNullable :: Column a -> Column (Nullable a)-toNullable = unsafeCoerce
− Opaleye/Distinct.hs
@@ -1,13 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}--module Opaleye.Distinct (module Opaleye.Distinct, distinctExplicit)- where--import Opaleye.QueryArr (Query)-import Opaleye.Internal.Distinct (distinctExplicit, Distinctspec)--import qualified Data.Profunctor.Product.Default as D--distinct :: D.Default Distinctspec columns columns =>- Query columns -> Query columns-distinct = distinctExplicit D.def
− Opaleye/Internal/Aggregate.hs
@@ -1,67 +0,0 @@-module Opaleye.Internal.Aggregate where--import Control.Applicative (Applicative, pure, (<*>))--import qualified Data.Profunctor as P-import qualified Data.Profunctor.Product as PP--import qualified Opaleye.Internal.PackMap as PM-import qualified Opaleye.Internal.PrimQuery as PQ-import qualified Opaleye.Internal.Tag as T-import qualified Opaleye.Internal.Column as C--import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ--{-|-An 'Aggregator' takes a collection of rows of type @a@, groups-them, and transforms each group into a single row of type @b@. This-corresponds to aggregators using @GROUP BY@ in SQL.--}-newtype Aggregator a b = Aggregator- (PM.PackMap (HPQ.PrimExpr, Maybe HPQ.AggrOp) HPQ.PrimExpr- a b)--makeAggr' :: Maybe HPQ.AggrOp -> Aggregator (C.Column a) (C.Column b)-makeAggr' m = Aggregator (PM.PackMap- (\f (C.Column e) -> fmap C.Column (f (e, m))))--makeAggr :: HPQ.AggrOp -> Aggregator (C.Column a) (C.Column b)-makeAggr = makeAggr' . Just--runAggregator :: Applicative f => Aggregator a b- -> ((HPQ.PrimExpr, Maybe HPQ.AggrOp) -> f HPQ.PrimExpr) -> a -> f b-runAggregator (Aggregator a) = PM.packmap a--aggregateU :: Aggregator a b- -> (a, PQ.PrimQuery, T.Tag) -> (b, PQ.PrimQuery, T.Tag)-aggregateU agg (c0, primQ, t0) = (c1, primQ', T.next t0)- where (c1, projPEs) =- PM.run (runAggregator agg (extractAggregateFields t0) c0)-- primQ' = PQ.Aggregate projPEs primQ--extractAggregateFields :: T.Tag -> (HPQ.PrimExpr, Maybe HPQ.AggrOp)- -> PM.PM [(String, Maybe HPQ.AggrOp, HPQ.PrimExpr)] HPQ.PrimExpr-extractAggregateFields tag (pe, maggrop) = do- i <- PM.new- let s = T.tagWith tag ("result" ++ i)- PM.write (s, maggrop, pe)- return (HPQ.AttrExpr s)---- { Boilerplate instances--instance Functor (Aggregator a) where- fmap f (Aggregator g) = Aggregator (fmap f g)--instance Applicative (Aggregator a) where- pure = Aggregator . pure- Aggregator f <*> Aggregator x = Aggregator (f <*> x)--instance P.Profunctor Aggregator where- dimap f g (Aggregator q) = Aggregator (P.dimap f g q)--instance PP.ProductProfunctor Aggregator where- empty = PP.defaultEmpty- (***!) = PP.defaultProfunctorProduct---- }
− Opaleye/Internal/Binary.hs
@@ -1,55 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts #-}--module Opaleye.Internal.Binary where--import Opaleye.Internal.Column (Column(Column))-import qualified Opaleye.Internal.Tag as T-import qualified Opaleye.Internal.PackMap as PM--import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ--import Data.Profunctor (Profunctor, dimap)-import Data.Profunctor.Product (ProductProfunctor, empty, (***!))-import qualified Data.Profunctor.Product as PP-import Data.Profunctor.Product.Default (Default, def)--import Control.Applicative (Applicative, pure, (<*>))-import Control.Arrow ((***))--extractBinaryFields :: T.Tag -> (HPQ.PrimExpr, HPQ.PrimExpr)- -> PM.PM [(String, (HPQ.PrimExpr, HPQ.PrimExpr))]- HPQ.PrimExpr-extractBinaryFields = PM.extractAttr ("binary" ++)--data Binaryspec columns columns' =- Binaryspec (PM.PackMap (HPQ.PrimExpr, HPQ.PrimExpr) HPQ.PrimExpr- (columns, columns) columns')--runBinaryspec :: Applicative f => Binaryspec columns columns'- -> ((HPQ.PrimExpr, HPQ.PrimExpr) -> f HPQ.PrimExpr)- -> (columns, columns) -> f columns'-runBinaryspec (Binaryspec b) = PM.packmap b--instance Default Binaryspec (Column a) (Column a) where- def = Binaryspec (PM.PackMap (\f (Column e, Column e')- -> fmap Column (f (e, e'))))---- {---- Boilerplate instance definitions. Theoretically, these are derivable.--instance Functor (Binaryspec a) where- fmap f (Binaryspec g) = Binaryspec (fmap f g)--instance Applicative (Binaryspec a) where- pure = Binaryspec . pure- Binaryspec f <*> Binaryspec x = Binaryspec (f <*> x)--instance Profunctor Binaryspec where- dimap f g (Binaryspec b) = Binaryspec (dimap (f *** f) g b)--instance ProductProfunctor Binaryspec where- empty = PP.defaultEmpty- (***!) = PP.defaultProfunctorProduct---- }
− Opaleye/Internal/Column.hs
@@ -1,65 +0,0 @@-module Opaleye.Internal.Column where--import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ-import qualified Opaleye.Internal.HaskellDB.Query as Q--import GHC.Int (Int64)---- | 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.-newtype Column a = Column HPQ.PrimExpr deriving Show--data Nullable a = Nullable--unColumn :: Column a -> HPQ.PrimExpr-unColumn (Column e) = e--unsafeCoerce :: Column a -> Column b-unsafeCoerce (Column e) = Column e---- This may well end up moving out somewhere else-constant :: Q.ShowConstant a => a -> Column a-constant = Column . HPQ.ConstExpr . Q.showConstant--binOp :: HPQ.BinOp -> Column a -> Column b -> Column c-binOp op (Column e) (Column e') = Column (HPQ.BinExpr op e e')--unOp :: HPQ.UnOp -> Column a -> Column b-unOp op (Column e) = Column (HPQ.UnExpr op e)--case_ :: [(Column Bool, Column a)] -> Column a -> Column a-case_ alts (Column otherwise_) = Column (HPQ.CaseExpr (unColumns alts) otherwise_)- where unColumns = map (\(Column e, Column e') -> (e, e'))--ifThenElse :: Column Bool -> Column a -> Column a -> Column a-ifThenElse cond t f = case_ [(cond, t)] f--(.>) :: Column a -> Column a -> Column Bool-(.>) = binOp HPQ.OpGt--(.==) :: Column a -> Column a -> Column Bool-(.==) = binOp HPQ.OpEq---- Naughty orphan instance-instance Q.ShowConstant Int64 where- showConstant = HPQ.IntegerLit . fromIntegral---- The constraints here are not really appropriate. There should be--- some restriction to a numeric Postgres type-instance (Q.ShowConstant a, Num a) => Num (Column a) where- fromInteger = constant . fromInteger- (*) = binOp HPQ.OpMul- (+) = binOp HPQ.OpPlus- (-) = binOp HPQ.OpMinus-- abs (Column e) = Column (HPQ.UnExpr (HPQ.UnOpOther "@") e)- negate (Column e) = Column (HPQ.UnExpr (HPQ.UnOpOther "-") e)-- -- We can't use Postgres's 'sign' function because it returns only a- -- numeric or a double- signum c = case_ [(c .> 0, 1), (c .== 0, 0)] (-1)--instance (Q.ShowConstant a, Fractional a) => Fractional (Column a) where- fromRational = constant . fromRational- (/) = binOp HPQ.OpDiv
− Opaleye/Internal/Distinct.hs
@@ -1,44 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}--module Opaleye.Internal.Distinct where--import Opaleye.QueryArr (Query)-import Opaleye.Column (Column)-import Opaleye.Aggregate (Aggregator, groupBy, aggregate)--import Control.Applicative (Applicative, pure, (<*>))--import qualified Data.Profunctor as P-import qualified Data.Profunctor.Product as PP-import Data.Profunctor.Product.Default (Default, def)---- We implement distinct simply by grouping by all columns. We could--- instead implement it as SQL's DISTINCT but implementing it in terms--- of something else that we already have is easier at this point.--distinctExplicit :: Distinctspec columns columns'- -> Query columns -> Query columns'-distinctExplicit (Distinctspec agg) = aggregate agg--data Distinctspec a b = Distinctspec (Aggregator a b)--instance Default Distinctspec (Column a) (Column a) where- def = Distinctspec groupBy---- { Boilerplate instances--instance Functor (Distinctspec a) where- fmap f (Distinctspec g) = Distinctspec (fmap f g)--instance Applicative (Distinctspec a) where- pure = Distinctspec . pure- Distinctspec f <*> Distinctspec x = Distinctspec (f <*> x)--instance P.Profunctor Distinctspec where- dimap f g (Distinctspec q) = Distinctspec (P.dimap f g q)--instance PP.ProductProfunctor Distinctspec where- empty = PP.defaultEmpty- (***!) = PP.defaultProfunctorProduct---- }
− Opaleye/Internal/HaskellDB/PrimQuery.hs
@@ -1,61 +0,0 @@--- Copyright : Daan Leijen (c) 1999, daan@cs.uu.nl--- HWT Group (c) 2003, haskelldb-users@lists.sourceforge.net--- License : BSD-style--module Opaleye.Internal.HaskellDB.PrimQuery where--type TableName = String-type Attribute = String-type Name = String-type Scheme = [Attribute]-type Assoc = [(Attribute,PrimExpr)]---data PrimExpr = AttrExpr Attribute- | BinExpr BinOp PrimExpr PrimExpr- | UnExpr UnOp PrimExpr- | AggrExpr AggrOp PrimExpr- | 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- | DefaultLit -- ^ represents a default value- | BoolLit Bool- | StringLit String- | IntegerLit Integer- | DoubleLit Double- | OtherLit String -- ^ used for hacking in custom SQL- deriving (Read,Show)--data BinOp = OpEq | OpLt | OpLtEq | OpGt | OpGtEq | OpNotEq - | OpAnd | OpOr- | OpLike | OpIn - | OpOther String-- | OpCat- | OpPlus | OpMinus | OpMul | OpDiv | OpMod- | OpBitNot | OpBitAnd | OpBitOr | OpBitXor- | OpAsg- deriving (Show,Read)--data UnOp = OpNot - | OpIsNull | OpIsNotNull- | OpLength- | UnOpOther String- deriving (Show,Read)--data AggrOp = AggrCount | AggrSum | AggrAvg | AggrMin | AggrMax- | AggrStdDev | AggrStdDevP | AggrVar | AggrVarP- | AggrOther String- deriving (Show,Read)--data OrderExpr = OrderExpr OrderOp PrimExpr - deriving (Show)--data OrderOp = OpAsc | OpDesc- deriving (Show)
− Opaleye/Internal/HaskellDB/Query.hs
@@ -1,26 +0,0 @@--- Copyright : Daan Leijen (c) 1999, daan@cs.uu.nl--- HWT Group (c) 2003, haskelldb-users@lists.sourceforge.net--- License : BSD-style--{-# LANGUAGE FlexibleContexts, FlexibleInstances, TypeSynonymInstances #-}--module Opaleye.Internal.HaskellDB.Query where--import Opaleye.Internal.HaskellDB.PrimQuery--class ShowConstant a where- showConstant :: a -> Literal--instance ShowConstant String where- showConstant = StringLit-instance ShowConstant Int where- showConstant = IntegerLit . fromIntegral-instance ShowConstant Integer where- showConstant = IntegerLit-instance ShowConstant Double where- showConstant = DoubleLit-instance ShowConstant Bool where- showConstant = BoolLit--instance ShowConstant a => ShowConstant (Maybe a) where- showConstant = maybe NullLit showConstant
− Opaleye/Internal/HaskellDB/Sql.hs
@@ -1,61 +0,0 @@--- Copyright : Daan Leijen (c) 1999, daan@cs.uu.nl--- HWT Group (c) 2003, haskelldb-users@lists.sourceforge.net--- License : BSD-style--module Opaleye.Internal.HaskellDB.Sql ( - SqlTable,- SqlColumn,- SqlName,- SqlOrder(..),-- SqlUpdate(..), - SqlDelete(..), - SqlInsert(..), -- SqlExpr(..),- Mark(..),- ) where----------------------------------------------------------------- * SQL data type--------------------------------------------------------------type SqlTable = String--type SqlColumn = String---- | A valid SQL name for a parameter.-type SqlName = String--data SqlOrder = SqlAsc | SqlDesc- deriving Show--data Mark = Columns [(SqlColumn, SqlExpr)]- deriving Show----- | Expressions in SQL statements.-data SqlExpr = ColumnSqlExpr SqlColumn- | BinSqlExpr String SqlExpr SqlExpr- | PrefixSqlExpr String SqlExpr- | PostfixSqlExpr String SqlExpr- | FunSqlExpr String [SqlExpr]- | AggrFunSqlExpr String [SqlExpr] -- ^ Aggregate functions separate from normal functions.- | ConstSqlExpr String- | CaseSqlExpr [(SqlExpr,SqlExpr)] SqlExpr- | ListSqlExpr [SqlExpr]- | ParamSqlExpr (Maybe SqlName) SqlExpr- | PlaceHolderSqlExpr- | ParensSqlExpr SqlExpr- | CastSqlExpr String SqlExpr - deriving Show---- | Data type for SQL UPDATE statements.-data SqlUpdate = SqlUpdate SqlTable [(SqlColumn,SqlExpr)] [SqlExpr]---- | Data type for SQL DELETE statements.-data SqlDelete = SqlDelete SqlTable [SqlExpr]----- | Data type for SQL INSERT statements.-data SqlInsert = SqlInsert SqlTable [SqlColumn] [SqlExpr]
− Opaleye/Internal/HaskellDB/Sql/Default.hs
@@ -1,190 +0,0 @@--- Copyright : Daan Leijen (c) 1999, daan@cs.uu.nl--- HWT Group (c) 2003, haskelldb-users@lists.sourceforge.net--- License : BSD-style--module Opaleye.Internal.HaskellDB.Sql.Default where--import Opaleye.Internal.HaskellDB.PrimQuery-import Opaleye.Internal.HaskellDB.Sql-import Opaleye.Internal.HaskellDB.Sql.Generate--mkSqlGenerator :: SqlGenerator -> SqlGenerator-mkSqlGenerator gen = SqlGenerator - {- sqlUpdate = defaultSqlUpdate gen,- sqlDelete = defaultSqlDelete gen,- sqlInsert = defaultSqlInsert gen,- sqlExpr = defaultSqlExpr gen,- sqlLiteral = defaultSqlLiteral gen,- sqlQuote = defaultSqlQuote gen- }--defaultSqlGenerator :: SqlGenerator-defaultSqlGenerator = mkSqlGenerator defaultSqlGenerator---toSqlOrder :: SqlGenerator -> OrderExpr -> (SqlExpr,SqlOrder)-toSqlOrder gen (OrderExpr o e) = (sqlExpr gen e, o')- where o' = case o of- OpAsc -> SqlAsc- OpDesc -> SqlDesc--toSqlAssoc :: SqlGenerator -> Assoc -> [(SqlColumn,SqlExpr)]-toSqlAssoc gen = map (\(attr,expr) -> (attr, sqlExpr gen expr))---defaultSqlUpdate :: SqlGenerator - -> TableName -- ^ Name of the 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 name (toSqlAssoc gen assigns) (map (sqlExpr gen) criteria) ---defaultSqlInsert :: SqlGenerator - -> TableName -- ^ Name of the table- -> Assoc -- ^ What to insert.- -> SqlInsert-defaultSqlInsert gen table assoc = SqlInsert table cs es- where (cs,es) = unzip (toSqlAssoc gen assoc)---defaultSqlDelete :: SqlGenerator - -> TableName -- ^ Name of the table- -> [PrimExpr] -- ^ Criteria which must all be true for a row- -- to be deleted.- -> SqlDelete-defaultSqlDelete gen name criteria = SqlDelete name (map (sqlExpr gen) criteria)---defaultSqlExpr :: SqlGenerator -> PrimExpr -> SqlExpr-defaultSqlExpr gen expr = - case expr of- AttrExpr a -> ColumnSqlExpr a- BinExpr op e1 e2 ->- let leftE = sqlExpr gen e1- rightE = sqlExpr gen e2- paren = ParensSqlExpr- (expL, expR) = case (op, e1, e2) of- (OpAnd, BinExpr OpOr _ _, BinExpr OpOr _ _) ->- (paren leftE, paren rightE)- (OpOr, BinExpr OpAnd _ _, BinExpr OpAnd _ _) ->- (paren leftE, paren rightE)- (OpAnd, BinExpr OpOr _ _, _) ->- (paren leftE, rightE)- (OpAnd, _, BinExpr OpOr _ _) ->- (leftE, paren rightE)- (OpOr, BinExpr OpAnd _ _, _) ->- (paren leftE, rightE)- (OpOr, _, BinExpr OpAnd _ _) ->- (leftE, paren 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' (ParensSqlExpr e')- UnOpPostfix -> PostfixSqlExpr op' e'- AggrExpr op e -> let op' = showAggrOp op- e' = sqlExpr gen e- in AggrFunSqlExpr op' [e']- ConstExpr l -> ConstSqlExpr (sqlLiteral gen l)- CaseExpr cs e -> let cs' = [(sqlExpr gen c, sqlExpr gen x)| (c,x) <- cs] - e' = sqlExpr gen e- in CaseSqlExpr cs' e'- ListExpr es -> ListSqlExpr (map (sqlExpr gen) es)- ParamExpr n _ -> 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 = "=" -showBinOp OpLt = "<" -showBinOp OpLtEq = "<=" -showBinOp OpGt = ">" -showBinOp OpGtEq = ">=" -showBinOp OpNotEq = "<>" -showBinOp OpAnd = "AND" -showBinOp OpOr = "OR" -showBinOp OpLike = "LIKE" -showBinOp OpIn = "IN" -showBinOp (OpOther s) = s-showBinOp OpCat = "+" -showBinOp OpPlus = "+" -showBinOp OpMinus = "-" -showBinOp OpMul = "*" -showBinOp OpDiv = "/" -showBinOp OpMod = "MOD" -showBinOp OpBitNot = "~" -showBinOp OpBitAnd = "&" -showBinOp OpBitOr = "|" -showBinOp OpBitXor = "^"-showBinOp OpAsg = "="---data UnOpType = UnOpFun | UnOpPrefix | UnOpPostfix--sqlUnOp :: UnOp -> (String,UnOpType)-sqlUnOp OpNot = ("NOT", UnOpPrefix)-sqlUnOp OpIsNull = ("IS NULL", UnOpPostfix)-sqlUnOp OpIsNotNull = ("IS NOT NULL", UnOpPostfix)-sqlUnOp OpLength = ("LENGTH", UnOpFun)-sqlUnOp (UnOpOther s) = (s, UnOpFun)---showAggrOp :: AggrOp -> String-showAggrOp AggrCount = "COUNT" -showAggrOp AggrSum = "SUM" -showAggrOp AggrAvg = "AVG" -showAggrOp AggrMin = "MIN" -showAggrOp AggrMax = "MAX" -showAggrOp AggrStdDev = "StdDev" -showAggrOp AggrStdDevP = "StdDevP" -showAggrOp AggrVar = "Var" -showAggrOp AggrVarP = "VarP" -showAggrOp (AggrOther s) = s---defaultSqlLiteral :: SqlGenerator -> Literal -> String-defaultSqlLiteral _ l = - case l of- NullLit -> "NULL"- DefaultLit -> "DEFAULT"- BoolLit True -> "TRUE"- BoolLit False -> "FALSE"- StringLit s -> quote s- IntegerLit i -> show i- DoubleLit d -> show d- OtherLit o -> o---defaultSqlQuote :: SqlGenerator -> String -> String-defaultSqlQuote _ s = quote s---- | Quote a string and escape characters that need escaping--- FIXME: this is *very* backend dependent.--- We use Postgres "escape strings", i.e. strings prefixed--- with E, to ensure that escaping with backslash is valid.-quote :: String -> String -quote s = "E'" ++ concatMap escape s ++ "'"---- | Escape characters that need escaping-escape :: Char -> String-escape '\NUL' = "\\0"-escape '\'' = "''"-escape '"' = "\\\""-escape '\b' = "\\b"-escape '\n' = "\\n"-escape '\r' = "\\r"-escape '\t' = "\\t"-escape '\\' = "\\\\"-escape c = [c]
− Opaleye/Internal/HaskellDB/Sql/Generate.hs
@@ -1,21 +0,0 @@--- Copyright : Daan Leijen (c) 1999, daan@cs.uu.nl--- HWT Group (c) 2003, haskelldb-users@lists.sourceforge.net--- License : BSD-style--module Opaleye.Internal.HaskellDB.Sql.Generate (SqlGenerator(..)) where--import Opaleye.Internal.HaskellDB.PrimQuery-import Opaleye.Internal.HaskellDB.Sql---data SqlGenerator = SqlGenerator- {- sqlUpdate :: TableName -> [PrimExpr] -> Assoc -> SqlUpdate,- sqlDelete :: TableName -> [PrimExpr] -> SqlDelete,- sqlInsert :: TableName -> Assoc -> SqlInsert,- sqlExpr :: PrimExpr -> SqlExpr,- sqlLiteral :: Literal -> String,- -- | Turn a string into a quoted string. Quote characters- -- and any escaping are handled by this function.- sqlQuote :: String -> String- }
− Opaleye/Internal/HaskellDB/Sql/Print.hs
@@ -1,103 +0,0 @@--- Copyright : Daan Leijen (c) 1999, daan@cs.uu.nl--- HWT Group (c) 2003, haskelldb-users@lists.sourceforge.net--- License : BSD-style--module Opaleye.Internal.HaskellDB.Sql.Print ( - ppUpdate,- ppDelete, - ppInsert,- ppSqlExpr,- ppWhere,- ppGroupBy,- ppOrderBy,- ppAs,- commaV,- commaH- ) where--import Opaleye.Internal.HaskellDB.Sql (Mark(Columns), SqlColumn, SqlDelete(..),- SqlExpr(..), SqlOrder(..), SqlInsert(..),- SqlUpdate(..))--import Data.List (intersperse)-import Text.PrettyPrint.HughesPJ (Doc, (<+>), ($$), (<>), comma, empty, equals,- hcat, hsep, parens, punctuate, text, vcat)---ppWhere :: [SqlExpr] -> Doc-ppWhere [] = empty-ppWhere es = text "WHERE" - <+> hsep (intersperse (text "AND")- (map (parens . ppSqlExpr) es))--ppGroupBy :: Mark -> Doc-ppGroupBy (Columns es) = text "GROUP BY" <+> ppGroupAttrs es- where- ppGroupAttrs :: [(SqlColumn, SqlExpr)] -> Doc- ppGroupAttrs cs = commaV nameOrExpr cs- nameOrExpr :: (SqlColumn, SqlExpr) -> Doc- nameOrExpr (_, ColumnSqlExpr col) = text col- nameOrExpr (_, expr) = parens (ppSqlExpr expr)- -ppOrderBy :: [(SqlExpr,SqlOrder)] -> Doc-ppOrderBy [] = empty-ppOrderBy ord = text "ORDER BY" <+> commaV ppOrd ord- where- ppOrd (e,o) = ppSqlExpr e <+> ppSqlOrder o- ppSqlOrder :: SqlOrder -> Doc- ppSqlOrder SqlAsc = text "ASC"- ppSqlOrder SqlDesc = text "DESC"--ppAs :: String -> Doc -> Doc-ppAs alias expr | null alias = expr - | otherwise = expr <+> (hsep . map text) ["as",alias]---ppUpdate :: SqlUpdate -> Doc-ppUpdate (SqlUpdate name assigns criteria)- = text "UPDATE" <+> text name- $$ text "SET" <+> commaV ppAssign assigns- $$ ppWhere criteria- where- ppAssign (c,e) = text c <+> equals <+> ppSqlExpr e---ppDelete :: SqlDelete -> Doc-ppDelete (SqlDelete name criteria) =- text "DELETE FROM" <+> text name $$ ppWhere criteria---ppInsert :: SqlInsert -> Doc--ppInsert (SqlInsert table names values)- = text "INSERT INTO" <+> text table - <+> parens (commaV text names)- $$ text "VALUES" <+> parens (commaV ppSqlExpr values)---ppSqlExpr :: SqlExpr -> Doc-ppSqlExpr expr =- case expr of- ColumnSqlExpr c -> text c- 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)- AggrFunSqlExpr f es -> text f <> parens (commaH ppSqlExpr es)- ConstSqlExpr c -> text c- CaseSqlExpr cs el -> text "CASE" <+> vcat (map ppWhen cs)- <+> text "ELSE" <+> ppSqlExpr el <+> text "END"- where ppWhen (w,t) = text "WHEN" <+> ppSqlExpr w - <+> text "THEN" <+> ppSqlExpr t- ListSqlExpr es -> parens (commaH ppSqlExpr es)- ParamSqlExpr _ v -> ppSqlExpr v- PlaceHolderSqlExpr -> text "?"- CastSqlExpr typ e -> text "CAST" <> parens (ppSqlExpr e <+> text "AS" <+> text typ)- --commaH :: (a -> Doc) -> [a] -> Doc-commaH f = hcat . punctuate comma . map f--commaV :: (a -> Doc) -> [a] -> Doc-commaV f = vcat . punctuate comma . map f
− Opaleye/Internal/Helpers.hs
@@ -1,16 +0,0 @@-module Opaleye.Internal.Helpers where--infixr 8 .:--(.:) :: (r -> z) -> (a -> b -> r) -> a -> b -> z-(.:) f g x y = f (g x y)--infixr 8 .:.--(.:.) :: (r -> z) -> (a -> b -> c -> r) -> a -> b -> c -> z-(.:.) f g a b c = f (g a b c)--infixr 8 .::--(.::) :: (r -> z) -> (a -> b -> c -> d -> r) -> a -> b -> c -> d -> z-(.::) f g a b c d = f (g a b c d)
− Opaleye/Internal/Join.hs
@@ -1,40 +0,0 @@-{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-}--module Opaleye.Internal.Join where--import qualified Opaleye.Internal.Tag as T-import qualified Opaleye.Internal.PackMap as PM-import Opaleye.Internal.Column (Column, Nullable)-import qualified Opaleye.Column as C--import Data.Profunctor (Profunctor, dimap)-import Data.Profunctor.Product (ProductProfunctor, empty, (***!))-import qualified Data.Profunctor.Product.Default as D--import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ--data NullMaker a b = NullMaker (a -> b)--toNullable :: NullMaker a b -> a -> b-toNullable (NullMaker f) = f--extractLeftJoinFields :: Int -> T.Tag -> HPQ.PrimExpr- -> PM.PM [(String, HPQ.PrimExpr)] HPQ.PrimExpr-extractLeftJoinFields n = PM.extractAttr (\i -> "result" ++ show n ++ "_" ++ i)--instance D.Default NullMaker (Column a) (Column (Nullable a)) where- def = NullMaker C.unsafeCoerce--instance D.Default NullMaker (Column (Nullable a)) (Column (Nullable a)) where- def = NullMaker C.unsafeCoerce---- { Boilerplate instances--instance Profunctor NullMaker where- dimap f g (NullMaker h) = NullMaker (dimap f g h)--instance ProductProfunctor NullMaker where- empty = NullMaker empty- NullMaker f ***! NullMaker f' = NullMaker (f ***! f')----
− Opaleye/Internal/Optimize.hs
@@ -1,31 +0,0 @@-module Opaleye.Internal.Optimize where--import Prelude hiding (product)--import qualified Opaleye.Internal.PrimQuery as PQ--import qualified Data.List.NonEmpty as NEL--optimize :: PQ.PrimQuery -> PQ.PrimQuery-optimize = mergeProduct . removeUnit--removeUnit :: PQ.PrimQuery -> PQ.PrimQuery-removeUnit = PQ.foldPrimQuery (PQ.Unit, PQ.BaseTable, product, PQ.Aggregate,- PQ.Order, PQ.Limit, PQ.Join, PQ.Values,- PQ.Binary)- where product pqs pes = PQ.Product pqs' pes- where pqs' = case NEL.filter (not . PQ.isUnit) pqs of- [] -> return PQ.Unit- xs -> NEL.fromList xs--mergeProduct :: PQ.PrimQuery -> PQ.PrimQuery-mergeProduct = PQ.foldPrimQuery (PQ.Unit, PQ.BaseTable, product, PQ.Aggregate,- PQ.Order, PQ.Limit, PQ.Join, PQ.Values,- PQ.Binary)- where product pqs pes = PQ.Product pqs' (pes ++ pes')- where pqs' = pqs >>= queries- queries (PQ.Product qs _) = qs- queries q = return q- pes' = NEL.toList pqs >>= conds- conds (PQ.Product _ cs) = cs- conds _ = []
− Opaleye/Internal/Order.hs
@@ -1,47 +0,0 @@-module Opaleye.Internal.Order where--import qualified Opaleye.Column as C-import qualified Opaleye.Internal.Column as IC-import qualified Opaleye.Internal.Tag as T-import qualified Opaleye.Internal.PrimQuery as PQ--import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ-import qualified Data.Functor.Contravariant as C-import qualified Data.Profunctor as P-import qualified Data.Monoid as M--data SingleOrder a = SingleOrder HPQ.OrderOp (a -> HPQ.PrimExpr)--instance C.Contravariant SingleOrder where- contramap f (SingleOrder op g) = SingleOrder op (P.lmap f g)--{-|-An `Order` represents an expression to order on and a sort-direction. Multiple `Order`s can be composed with-`Data.Monoid.mappend`. If two rows are equal according to the first-`Order`, the second is used, and so on.--}-newtype Order a = Order [SingleOrder a]--instance C.Contravariant Order where- contramap f (Order xs) = Order (fmap (C.contramap f) xs)--instance M.Monoid (Order a) where- mempty = Order M.mempty- Order o `mappend` Order o' = Order (o `M.mappend` o')--order :: HPQ.OrderOp -> (a -> C.Column b) -> Order a-order op f = C.contramap f (Order [SingleOrder op IC.unColumn])--orderByU :: Order a -> (a, PQ.PrimQuery, T.Tag) -> (a, PQ.PrimQuery, T.Tag)-orderByU os (columns, primQ, t) = (columns, primQ', t)- where primQ' = PQ.Order orderExprs primQ- Order sos = os- orderExprs = map (\(SingleOrder op f)- -> HPQ.OrderExpr op (f columns)) sos--limit' :: Int -> (a, PQ.PrimQuery, T.Tag) -> (a, PQ.PrimQuery, T.Tag)-limit' n (x, q, t) = (x, PQ.Limit (PQ.LimitOp n) q, t)--offset' :: Int -> (a, PQ.PrimQuery, T.Tag) -> (a, PQ.PrimQuery, T.Tag)-offset' n (x, q, t) = (x, PQ.Limit (PQ.OffsetOp n) q, t)
− Opaleye/Internal/PackMap.hs
@@ -1,102 +0,0 @@-{-# LANGUAGE Rank2Types #-}--module Opaleye.Internal.PackMap where--import qualified Opaleye.Internal.Tag as T--import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ--import Control.Applicative (Applicative, pure, (<*>), liftA2)-import qualified Control.Monad.Trans.State as State-import Data.Profunctor (Profunctor, dimap)-import Data.Profunctor.Product (ProductProfunctor, empty, (***!))-import qualified Data.Profunctor.Product as PP-import qualified Data.Functor.Identity as I---- This is rather like a Control.Lens.Traversal with the type--- parameters switched but I'm not sure if it should be required to--- obey the same laws.------ TODO: We could attempt to generalise this to------ data LensLike f a b s t = LensLike ((a -> f b) -> s -> f t)------ i.e. a wrapped, argument-flipped Control.Lens.LensLike------ This would allow us to do the Profunctor and ProductProfunctor--- instances (requiring just Functor f and Applicative f respectively)--- and share them between many different restrictions of f. For--- example, TableColumnMaker is like a Setter so we would restrict f--- to the Distributive case.-data PackMap a b s t = PackMap (Applicative f =>- (a -> f b) -> s -> f t)--packmap :: Applicative f => PackMap a b s t -> (a -> f b) -> s -> f t-packmap (PackMap f) = f--over :: PackMap a b s t -> (a -> b) -> s -> t-over p f = I.runIdentity . packmap p (I.Identity . f)----- { A helpful monad for writing columns in the AST--type PM a = State.State (a, Int)--new :: PM a String-new = do- (a, i) <- State.get- State.put (a, i + 1)- return (show i)--write :: a -> PM [a] ()-write a = do- (as, i) <- State.get- State.put (as ++ [a], i)--run :: PM [a] r -> (r, [a])-run m = (r, as)- where (r, (as, _)) = State.runState m ([], 0)---- }----- { General functions for writing columns in the AST---- This one ignores the 'a' when making the internal column name.-extractAttr :: (String -> String) -> T.Tag -> a- -> PM [(String, a)] HPQ.PrimExpr-extractAttr = extractAttrPE . const---- This one can make the internal column name depend on the 'a' in--- question (probably a PrimExpr)-extractAttrPE :: (a -> String -> String) -> T.Tag -> a- -> PM [(String, a)] HPQ.PrimExpr-extractAttrPE mkName t pe = do- i <- new- let s = T.tagWith t (mkName pe i)- write (s, pe)- return (HPQ.AttrExpr s)---- }----- {---- Boilerplate instance definitions. There's no choice here apart--- from the order in which the applicative is applied.--instance Functor (PackMap a b s) where- fmap f (PackMap g) = PackMap ((fmap . fmap . fmap) f g)--instance Applicative (PackMap a b s) where- pure x = PackMap (pure (pure (pure x)))- PackMap f <*> PackMap x = PackMap (liftA2 (liftA2 (<*>)) f x)--instance Profunctor (PackMap a b) where- dimap f g (PackMap q) = PackMap (fmap (dimap f (fmap g)) q)--instance ProductProfunctor (PackMap a b) where- empty = PP.defaultEmpty- (***!) = PP.defaultProfunctorProduct---- }
− Opaleye/Internal/PrimQuery.hs
@@ -1,62 +0,0 @@-module Opaleye.Internal.PrimQuery where--import Prelude hiding (product)--import qualified Data.List.NonEmpty as NEL-import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ--type Symbol = String--data LimitOp = LimitOp Int | OffsetOp Int | LimitOffsetOp Int Int- deriving Show--data BinOp = Except | Union | UnionAll deriving Show-data JoinType = LeftJoin deriving Show---- 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)]- | Product (NEL.NonEmpty PrimQuery) [HPQ.PrimExpr]- | Aggregate [(Symbol, Maybe HPQ.AggrOp, HPQ.PrimExpr)] PrimQuery- | Order [HPQ.OrderExpr] PrimQuery- | Limit LimitOp PrimQuery- | Join JoinType [(Symbol, HPQ.PrimExpr)] HPQ.PrimExpr PrimQuery PrimQuery- | Values [Symbol] [[HPQ.PrimExpr]]- | Binary BinOp [(Symbol, (HPQ.PrimExpr, HPQ.PrimExpr))] (PrimQuery, PrimQuery)- deriving Show--type PrimQueryFold p = ( p- , String -> [(Symbol, HPQ.PrimExpr)] -> p- , NEL.NonEmpty p -> [HPQ.PrimExpr] -> p- , [(Symbol, Maybe HPQ.AggrOp, HPQ.PrimExpr)] -> p -> p- , [HPQ.OrderExpr] -> p -> p- , LimitOp -> p -> p- , JoinType -> [(Symbol, HPQ.PrimExpr)] -> HPQ.PrimExpr -> p -> p -> p- , [Symbol] -> [[HPQ.PrimExpr]] -> p- , BinOp -> [(Symbol, (HPQ.PrimExpr, HPQ.PrimExpr))] -> (p, p) -> p- )--foldPrimQuery :: PrimQueryFold p -> PrimQuery -> p-foldPrimQuery (unit, baseTable, product, aggregate, order, limit, join, values,- binary)- = fold where fold primQ = case primQ of- Unit -> unit- BaseTable n s -> baseTable n s- Product pqs pes -> product (fmap fold pqs) pes- Aggregate aggrs pq -> aggregate aggrs (fold pq)- Order pes pq -> order pes (fold pq)- Limit op pq -> limit op (fold pq)- Join j pes cond q1 q2 -> join j pes cond (fold q1) (fold q2)- Values ss pes -> values ss pes- Binary binop pes (pq, pq') -> binary binop pes (fold pq, fold pq')--times :: PrimQuery -> PrimQuery -> PrimQuery-times q q' = Product (q NEL.:| [q']) []--restrict :: HPQ.PrimExpr -> PrimQuery -> PrimQuery-restrict cond primQ = Product (return primQ) [cond]--isUnit :: PrimQuery -> Bool-isUnit Unit = True-isUnit _ = False
− Opaleye/Internal/Print.hs
@@ -1,115 +0,0 @@-module Opaleye.Internal.Print where--import Prelude hiding (product)--import qualified Opaleye.Internal.Sql as Sql-import Opaleye.Internal.Sql (Select(SelectFrom, Table,- SelectJoin,- SelectValues,- SelectBinary),- From, Join, Values, Binary)--import qualified Opaleye.Internal.HaskellDB.Sql as HSql-import qualified Opaleye.Internal.HaskellDB.Sql.Print as HPrint--import Text.PrettyPrint.HughesPJ (Doc, ($$), (<+>), text, empty,- parens)--import qualified Data.Maybe as M--ppSql :: Select -> Doc-ppSql (SelectFrom s) = ppSelectFrom s-ppSql (Table name) = text name-ppSql (SelectJoin j) = ppSelectJoin j-ppSql (SelectValues v) = ppSelectValues v-ppSql (SelectBinary v) = ppSelectBinary v--ppSelectFrom :: From -> Doc-ppSelectFrom s = text "SELECT"- <+> ppAttrs (Sql.attrs s)- $$ ppTables (Sql.tables s)- $$ HPrint.ppWhere (Sql.criteria s)- $$ ppGroupBy (Sql.groupBy s)- $$ HPrint.ppOrderBy (Sql.orderBy s)- $$ ppLimit (Sql.limit s)- $$ ppOffset (Sql.offset s)---ppSelectJoin :: Join -> Doc-ppSelectJoin j = text "SELECT"- <+> ppAttrs (Sql.jAttrs j)- $$ text "FROM"- $$ ppTable (tableAlias 1 s1)- $$ ppJoinType (Sql.jJoinType j)- $$ ppTable (tableAlias 2 s2)- $$ text "ON"- $$ HPrint.ppSqlExpr (Sql.jCond j)- where (s1, s2) = Sql.jTables j--ppSelectValues :: Values -> Doc-ppSelectValues v = text "SELECT"- <+> ppAttrs (Sql.vAttrs v)- $$ text "FROM"- $$ ppValues (Sql.vValues v)--ppSelectBinary :: Binary -> Doc-ppSelectBinary b = ppSql (Sql.bSelect1 b)- $$ ppBinOp (Sql.bOp b)- $$ ppSql (Sql.bSelect2 b)--ppJoinType :: Sql.JoinType -> Doc-ppJoinType Sql.LeftJoin = text "LEFT OUTER JOIN"--ppAttrs :: [(HSql.SqlExpr, Maybe HSql.SqlColumn)] -> Doc-ppAttrs [] = text "*"-ppAttrs xs = HPrint.commaV nameAs xs---- This is pretty much just nameAs from HaskellDB-nameAs :: (HSql.SqlExpr, Maybe HSql.SqlColumn) -> Doc-nameAs (expr, name) = HPrint.ppAs (M.fromMaybe "" name) (HPrint.ppSqlExpr expr)--ppTables :: [Select] -> Doc-ppTables [] = empty-ppTables ts = text "FROM" <+> HPrint.commaV ppTable (zipWith tableAlias [1..] ts)--tableAlias :: Int -> Select -> (HSql.SqlTable, Select)-tableAlias i select = ("T" ++ show i, select)---- TODO: duplication with ppSql-ppTable :: (HSql.SqlTable, Select) -> Doc-ppTable (alias, select) = case select of- Table name -> HPrint.ppAs alias (text name)- SelectFrom selectFrom -> HPrint.ppAs alias (parens (ppSelectFrom selectFrom))- SelectJoin slj -> HPrint.ppAs alias (parens (ppSelectJoin slj))- SelectValues slv -> HPrint.ppAs alias (parens (ppSelectValues slv))- SelectBinary slb -> HPrint.ppAs alias (parens (ppSelectBinary slb))--ppGroupBy :: [HSql.SqlExpr] -> Doc-ppGroupBy [] = empty-ppGroupBy xs = (HPrint.ppGroupBy . HSql.Columns . map (\expr -> ("", expr))) xs--ppLimit :: Maybe Int -> Doc-ppLimit Nothing = empty-ppLimit (Just n) = text ("LIMIT " ++ show n)--ppOffset :: Maybe Int -> Doc-ppOffset Nothing = empty-ppOffset (Just n) = text ("OFFSET " ++ show n)--ppValues :: [[HSql.SqlExpr]] -> Doc-ppValues v = HPrint.ppAs "V" (parens (text "VALUES" $$ HPrint.commaV ppValuesRow v))--ppValuesRow :: [HSql.SqlExpr] -> Doc-ppValuesRow = parens . HPrint.commaH HPrint.ppSqlExpr--ppBinOp :: Sql.BinOp -> Doc-ppBinOp o = text $ case o of- Sql.Union -> "UNION"- Sql.UnionAll -> "UNION ALL"- Sql.Except -> "EXCEPT"--ppInsertReturning :: Sql.Returning HSql.SqlInsert -> Doc-ppInsertReturning (Sql.Returning insert returnExprs) =- HPrint.ppInsert insert- $$ text "RETURNING"- <+> HPrint.commaV HPrint.ppSqlExpr returnExprs
− Opaleye/Internal/QueryArr.hs
@@ -1,67 +0,0 @@-module Opaleye.Internal.QueryArr where--import Prelude hiding (id)--import qualified Opaleye.Internal.Unpackspec as U-import qualified Opaleye.Internal.Tag as Tag-import Opaleye.Internal.Tag (Tag)-import qualified Opaleye.Internal.PrimQuery as PQ--import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ--import qualified Control.Arrow as Arr-import Control.Arrow ((&&&), (***), arr)-import qualified Control.Category as C-import Control.Category ((<<<), id)-import Control.Applicative (Applicative, pure, (<*>))-import qualified Data.Profunctor as P-import qualified Data.Profunctor.Product as PP--newtype QueryArr a b = QueryArr ((a, PQ.PrimQuery, Tag) -> (b, PQ.PrimQuery, Tag))-type Query = QueryArr ()--simpleQueryArr :: ((a, Tag) -> (b, PQ.PrimQuery, Tag)) -> QueryArr a b-simpleQueryArr f = QueryArr g- where g (a0, primQuery, t0) = (a1, PQ.times primQuery primQuery', t1)- where (a1, primQuery', t1) = f (a0, t0)--runQueryArr :: QueryArr a b -> (a, PQ.PrimQuery, Tag) -> (b, PQ.PrimQuery, Tag)-runQueryArr (QueryArr f) = f--runSimpleQueryArr :: QueryArr a b -> (a, Tag) -> (b, PQ.PrimQuery, Tag)-runSimpleQueryArr f (a, t) = runQueryArr f (a, PQ.Unit, t)--runQueryArrUnpack :: U.Unpackspec a b- -> Query a -> (PQ.PrimQuery, [HPQ.PrimExpr])-runQueryArrUnpack unpackspec q = (primQ, primExprs)- where (columns, primQ, _) = runSimpleQueryArr q ((), Tag.start)- f pe = ([pe], pe)- primExprs :: [HPQ.PrimExpr]- (primExprs, _) = U.runUnpackspec unpackspec f columns--first3 :: (a1 -> b) -> (a1, a2, a3) -> (b, a2, a3)-first3 f (a1, a2, a3) = (f a1, a2, a3)--instance C.Category QueryArr where- id = QueryArr id- QueryArr f . QueryArr g = QueryArr (f . g)--instance Arr.Arrow QueryArr where- arr f = QueryArr (first3 f)- first f = QueryArr g- where g ((b, d), primQ, t0) = ((c, d), primQ', t1)- where (c, primQ', t1) = runQueryArr f (b, primQ, t0)--instance Functor (QueryArr a) where- fmap f = (arr f <<<)--instance Applicative (QueryArr a) where- pure = arr . const- f <*> g = arr (uncurry ($)) <<< (f &&& g)--instance P.Profunctor QueryArr where- dimap f g a = arr g <<< a <<< arr f--instance PP.ProductProfunctor QueryArr where- empty = id- (***!) = (***)
− Opaleye/Internal/RunQuery.hs
@@ -1,98 +0,0 @@-{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-}--module Opaleye.Internal.RunQuery where--import Control.Applicative (Applicative, pure, (<*>))--import Database.PostgreSQL.Simple.Internal (RowParser)-import Database.PostgreSQL.Simple.FromField (FieldParser, FromField,- fromField)-import Database.PostgreSQL.Simple.FromRow (fieldWith)--import Opaleye.Column (Column)-import Opaleye.Internal.Column (Nullable)-import qualified Opaleye.Column as C-import qualified Opaleye.Internal.Unpackspec as U--import qualified Data.Profunctor as P-import Data.Profunctor (dimap)-import qualified Data.Profunctor.Product as PP-import Data.Profunctor.Product (empty, (***!))-import qualified Data.Profunctor.Product.Default as D--import GHC.Int (Int64)--data QueryRunnerColumn coltype haskell =- QueryRunnerColumn (U.Unpackspec (Column coltype) ()) (FieldParser haskell)--data QueryRunner columns haskells = QueryRunner (U.Unpackspec columns ())- (RowParser haskells)--fieldQueryRunnerColumn :: FromField haskell => QueryRunnerColumn coltype haskell-fieldQueryRunnerColumn =- QueryRunnerColumn (P.rmap (const ()) U.unpackspecColumn) fromField--queryRunner :: QueryRunnerColumn a b -> QueryRunner (Column a) b-queryRunner qrc = QueryRunner u (fieldWith fp)- where QueryRunnerColumn u fp = qrc--queryRunnerColumnNullable :: QueryRunnerColumn a b- -> QueryRunnerColumn (Nullable a) (Maybe b)-queryRunnerColumnNullable qr =- QueryRunnerColumn (P.lmap C.unsafeCoerce u) (fromField' fp)- where QueryRunnerColumn u fp = qr- fromField' :: FieldParser a -> FieldParser (Maybe a)- fromField' _ _ Nothing = pure Nothing- fromField' fp' f bs = fmap Just (fp' f bs)---- { Instances for automatic derivation--instance D.Default QueryRunnerColumn a b =>- D.Default QueryRunnerColumn (Nullable a) (Maybe b) where- def = queryRunnerColumnNullable D.def--instance D.Default QueryRunnerColumn a b =>- D.Default QueryRunner (Column a) b where- def = queryRunner D.def---- }---- { Instances that must be provided once for each type. Instances--- for Nullable are derived automatically from these.--instance D.Default QueryRunnerColumn Int Int where- def = fieldQueryRunnerColumn--instance D.Default QueryRunnerColumn Int64 Int64 where- def = fieldQueryRunnerColumn--instance D.Default QueryRunnerColumn Integer Integer where- def = fieldQueryRunnerColumn--instance D.Default QueryRunnerColumn String String where- def = fieldQueryRunnerColumn--instance D.Default QueryRunnerColumn Double Double where- def = fieldQueryRunnerColumn---- }---- Boilerplate instances--instance Functor (QueryRunner c) where- fmap f (QueryRunner u r) = QueryRunner u (fmap f r)---- TODO: Seems like this one should be simpler!-instance Applicative (QueryRunner c) where- pure = QueryRunner (P.lmap (const ()) PP.empty) . pure- QueryRunner uf rf <*> QueryRunner ux rx =- QueryRunner (P.dimap (\x -> (x,x)) (const ()) (uf PP.***! ux)) (rf <*> rx)--instance P.Profunctor QueryRunner where- dimap f g (QueryRunner u r) = QueryRunner (P.lmap f u) (fmap g r)--instance PP.ProductProfunctor QueryRunner where- empty = PP.defaultEmpty- (***!) = PP.defaultProfunctorProduct---- }
− Opaleye/Internal/Sql.hs
@@ -1,155 +0,0 @@-module Opaleye.Internal.Sql where--import Prelude hiding (product)--import qualified Opaleye.Internal.PrimQuery as PQ--import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ-import qualified Opaleye.Internal.HaskellDB.Sql as HSql-import qualified Opaleye.Internal.HaskellDB.Sql.Default as SD-import qualified Opaleye.Internal.HaskellDB.Sql.Generate as SG--import qualified Data.List.NonEmpty as NEL-import qualified Data.Maybe as M--data Select = SelectFrom From- | Table HSql.SqlTable- | SelectJoin Join- | SelectValues Values- | SelectBinary Binary- deriving Show--data From = From {- attrs :: [(HSql.SqlExpr, Maybe HSql.SqlColumn)],- tables :: [Select],- criteria :: [HSql.SqlExpr],- groupBy :: [HSql.SqlExpr],- orderBy :: [(HSql.SqlExpr, HSql.SqlOrder)],- limit :: Maybe Int,- offset :: Maybe Int- }- deriving Show--data Join = Join {- jJoinType :: JoinType,- jAttrs :: [(HSql.SqlExpr, Maybe HSql.SqlColumn)],- jTables :: (Select, Select),- jCond :: HSql.SqlExpr- }- deriving Show--data Values = Values {- vAttrs :: [(HSql.SqlExpr, Maybe HSql.SqlColumn)],- vValues :: [[HSql.SqlExpr]]-} deriving Show--data Binary = Binary {- bOp :: BinOp,- bSelect1 :: Select,- bSelect2 :: Select-} deriving Show--data JoinType = LeftJoin deriving Show-data BinOp = Except | Union | UnionAll deriving Show--data TableName = String--data Returning a = Returning a [HSql.SqlExpr]--sqlQueryGenerator :: PQ.PrimQueryFold Select-sqlQueryGenerator = (unit, baseTable, product, aggregate, order, limit_, join,- values, binary)--sql :: (PQ.PrimQuery, [HPQ.PrimExpr]) -> Select-sql (pq, pes) = SelectFrom $ newSelect { attrs = makeAttrs pes- , tables = [pqSelect] }- where pqSelect = PQ.foldPrimQuery sqlQueryGenerator pq- makeAttrs = flip (zipWith makeAttr) [1..]- makeAttr pe i = (sqlExpr pe, Just ("result" ++ show (i :: Int)))--unit :: Select-unit = SelectFrom newSelect { attrs = [(HSql.ConstSqlExpr "0", Nothing)] }--baseTable :: String -> [(PQ.Symbol, HPQ.PrimExpr)] -> Select-baseTable name columns = SelectFrom $- newSelect { attrs = map (\(sym, col) -> (sqlExpr col, Just sym)) columns- , tables = [Table name] }--product :: NEL.NonEmpty Select -> [HPQ.PrimExpr] -> Select-product ss pes = SelectFrom $- newSelect { tables = NEL.toList ss- , criteria = map sqlExpr pes }--aggregate :: [(PQ.Symbol, Maybe HPQ.AggrOp, HPQ.PrimExpr)] -> Select -> Select-aggregate aggrs s = SelectFrom $ newSelect { attrs = map attr aggrs- , tables = [s]- , groupBy = groupBy' }- where groupBy' = (map sqlExpr- . map (\(_, _, e) -> e)- . filter (\(_, x, _) -> M.isNothing x)) aggrs- attr (x, aggrOp, pe) = (sqlExpr (aggrExpr aggrOp pe), Just x)--aggrExpr :: Maybe HPQ.AggrOp -> HPQ.PrimExpr -> HPQ.PrimExpr-aggrExpr = maybe id HPQ.AggrExpr--order :: [HPQ.OrderExpr] -> Select -> Select-order oes s = SelectFrom $- newSelect { tables = [s]- , orderBy = map (SD.toSqlOrder SD.defaultSqlGenerator) oes }--limit_ :: PQ.LimitOp -> Select -> Select-limit_ lo s = SelectFrom $ newSelect { tables = [s]- , limit = limit'- , offset = offset' }- where (limit', offset') = case lo of- PQ.LimitOp n -> (Just n, Nothing)- PQ.OffsetOp n -> (Nothing, Just n)- PQ.LimitOffsetOp l o -> (Just l, Just o)--join :: PQ.JoinType -> [(PQ.Symbol, HPQ.PrimExpr)] -> HPQ.PrimExpr -> Select -> Select- -> Select-join j columns cond s1 s2 = SelectJoin Join { jJoinType = joinType j- , jAttrs = mkAttrs columns- , jTables = (s1, s2)- , jCond = sqlExpr cond }- where mkAttrs = map (\(sym, pe) -> (sqlExpr pe, Just sym))--values :: [PQ.Symbol] -> [[HPQ.PrimExpr]] -> Select-values columns pes = SelectValues Values { vAttrs = mkColumns columns- , vValues = (map . map) sqlExpr pes }- where mkColumns = zipWith (\i column -> ((sqlExpr . HPQ.AttrExpr) ("column" ++ show (i::Int)),- Just column)) [1..]--binary :: PQ.BinOp -> [(PQ.Symbol, (HPQ.PrimExpr, HPQ.PrimExpr))]- -> (Select, Select) -> Select-binary op pes (select1, select2) = SelectBinary Binary {- bOp = binOp op,- bSelect1 = SelectFrom newSelect { attrs = map (mkColumn fst) pes,- tables = [select1] },- bSelect2 = SelectFrom newSelect { attrs = map (mkColumn snd) pes,- tables = [select2] }- }- where mkColumn e (sym, pes') = (sqlExpr (e pes'), Just sym)--joinType :: PQ.JoinType -> JoinType-joinType PQ.LeftJoin = LeftJoin--binOp :: PQ.BinOp -> BinOp-binOp o = case o of- PQ.Except -> Except- PQ.Union -> Union- PQ.UnionAll -> UnionAll--newSelect :: From-newSelect = From {- attrs = [],- tables = [],- criteria = [],- groupBy = [],- orderBy = [],- limit = Nothing,- offset = Nothing- }--sqlExpr :: HPQ.PrimExpr -> HSql.SqlExpr-sqlExpr = SG.sqlExpr SD.defaultSqlGenerator
− Opaleye/Internal/Table.hs
@@ -1,110 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}--module Opaleye.Internal.Table where--import Opaleye.Internal.Column (Column(Column))-import qualified Opaleye.Internal.TableMaker as TM-import qualified Opaleye.Internal.Tag as Tag-import qualified Opaleye.Internal.PrimQuery as PQ-import qualified Opaleye.Internal.PackMap as PM--import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ--import Data.Profunctor (Profunctor, dimap, lmap)-import Data.Profunctor.Product (ProductProfunctor, empty, (***!))-import qualified Data.Profunctor.Product as PP-import Control.Applicative (Applicative, pure, (<*>), liftA2)--data Table writerColumns viewColumns =- Table String (TableProperties writerColumns viewColumns)--data TableProperties writerColumns viewColumns =- TableProperties (Writer writerColumns viewColumns) (View viewColumns)--data View columns = View columns---- If we switch to a more lens-like approach to PackMap this should be--- the equivalent of a Fold---- There's no reason the second parameter should exist except that we--- use ProductProfunctors more than ProductContravariants so it makes--- things easier if we make it one of the former.-data Writer columns dummy =- Writer (PM.PackMap (HPQ.PrimExpr, String) () columns ())--queryTable :: TM.ColumnMaker viewColumns columns- -> Table writerColumns viewColumns- -> Tag.Tag- -> (columns, PQ.PrimQuery)-queryTable cm table tag = (primExprs, primQ) where- (Table tableName (TableProperties _ (View tableCols))) = table- (primExprs, projcols) = runColumnMaker cm tag tableCols- primQ :: PQ.PrimQuery- primQ = PQ.BaseTable tableName projcols--runColumnMaker :: TM.ColumnMaker tablecolumns columns- -> Tag.Tag- -> tablecolumns- -> (columns, [(String, HPQ.PrimExpr)])-runColumnMaker cm tag tableCols = PM.run (TM.runColumnMaker cm f tableCols) where- f = PM.extractAttrPE mkName tag- -- The non-AttrExpr PrimExprs are not created by 'makeView' or a- -- 'ViewColumnMaker' so could only arise from an fmap (if we- -- implemented a Functor instance) or a direct manipulation of the- -- tablecols contained in the View (which would be naughty)- mkName pe i = (++ i) $ case pe of- HPQ.AttrExpr columnName -> columnName- _ -> "tablecolumn"--runWriter :: Writer columns columns' -> columns -> [(HPQ.PrimExpr, String)]-runWriter (Writer (PM.PackMap f)) columns = outColumns- where extractColumns t = ([t], ())- (outColumns, ()) = f extractColumns columns--required :: String -> Writer (Column a) (Column a)-required columnName =- Writer (PM.PackMap (\f (Column primExpr) -> f (primExpr, columnName)))--optional :: String -> Writer (Maybe (Column a)) (Column a)-optional columnName =- Writer (PM.PackMap (\f c -> case c of- Nothing -> pure ()- Just (Column primExpr) -> f (primExpr, columnName)))---- {---- Boilerplate instance definitions--instance Functor (Writer a) where- fmap _ (Writer g) = Writer g--instance Applicative (Writer a) where- pure x = Writer (fmap (const ()) (pure x))- Writer f <*> Writer x = Writer (liftA2 (\_ _ -> ()) f x)--instance Profunctor Writer where- dimap f _ (Writer h) = Writer (lmap f h)--instance ProductProfunctor Writer where- empty = PP.defaultEmpty- (***!) = PP.defaultProfunctorProduct--instance Functor (TableProperties a) where- fmap f (TableProperties w (View v)) = TableProperties (fmap f w) (View (f v))--instance Applicative (TableProperties a) where- pure x = TableProperties (pure x) (View x)- TableProperties fw (View fv) <*> TableProperties xw (View xv) =- TableProperties (fw <*> xw) (View (fv xv))--instance Profunctor TableProperties where- dimap f g (TableProperties w (View v)) = TableProperties (dimap f g w)- (View (g v))-instance ProductProfunctor TableProperties where- empty = PP.defaultEmpty- (***!) = PP.defaultProfunctorProduct--instance Functor (Table a) where- fmap f (Table s tp) = Table s (fmap f tp)---- }
− Opaleye/Internal/TableMaker.hs
@@ -1,85 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}--module Opaleye.Internal.TableMaker where--import qualified Opaleye.Column as C-import qualified Opaleye.Internal.Column as IC-import qualified Opaleye.Internal.PackMap as PM--import Data.Profunctor (Profunctor, dimap)-import Data.Profunctor.Product (ProductProfunctor, empty, (***!))-import qualified Data.Profunctor.Product as PP-import Data.Profunctor.Product.Default (Default, def)--import Control.Applicative (Applicative, pure, (<*>))--import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ----- If we switch to a more lens-like approach to PackMap this should be--- the equivalent of a Setter-newtype ViewColumnMaker strings columns =- ViewColumnMaker (PM.PackMap () () strings columns)--newtype ColumnMaker columns columns' =- ColumnMaker (PM.PackMap HPQ.PrimExpr HPQ.PrimExpr columns columns')--runViewColumnMaker :: ViewColumnMaker strings tablecolumns ->- strings -> tablecolumns-runViewColumnMaker (ViewColumnMaker f) = PM.over f id--runColumnMaker :: Applicative f- => ColumnMaker tablecolumns columns- -> (HPQ.PrimExpr -> f HPQ.PrimExpr)- -> tablecolumns -> f columns-runColumnMaker (ColumnMaker f) = PM.packmap f---- There's surely a way of simplifying this implementation-tableColumn :: ViewColumnMaker String (C.Column a)-tableColumn = ViewColumnMaker- (PM.PackMap (\f s -> fmap (const ((IC.Column . HPQ.AttrExpr) s)) (f ())))--column :: ColumnMaker (C.Column a) (C.Column a)-column = ColumnMaker- (PM.PackMap (\f (IC.Column s)- -> fmap IC.Column (f s)))--instance Default ViewColumnMaker String (C.Column a) where- def = tableColumn--instance Default ColumnMaker (C.Column a) (C.Column a) where- def = column---- {---- Boilerplate instance definitions. Theoretically, these are derivable.--instance Functor (ViewColumnMaker a) where- fmap f (ViewColumnMaker g) = ViewColumnMaker (fmap f g)--instance Applicative (ViewColumnMaker a) where- pure = ViewColumnMaker . pure- ViewColumnMaker f <*> ViewColumnMaker x = ViewColumnMaker (f <*> x)--instance Profunctor ViewColumnMaker where- dimap f g (ViewColumnMaker q) = ViewColumnMaker (dimap f g q)--instance ProductProfunctor ViewColumnMaker where- empty = PP.defaultEmpty- (***!) = PP.defaultProfunctorProduct--instance Functor (ColumnMaker a) where- fmap f (ColumnMaker g) = ColumnMaker (fmap f g)--instance Applicative (ColumnMaker a) where- pure = ColumnMaker . pure- ColumnMaker f <*> ColumnMaker x = ColumnMaker (f <*> x)--instance Profunctor ColumnMaker where- dimap f g (ColumnMaker q) = ColumnMaker (dimap f g q)--instance ProductProfunctor ColumnMaker where- empty = PP.defaultEmpty- (***!) = PP.defaultProfunctorProduct----}
− Opaleye/Internal/Tag.hs
@@ -1,18 +0,0 @@-module Opaleye.Internal.Tag where--data Tag = UnsafeTag Int--start :: Tag-start = UnsafeTag 1--next :: Tag -> Tag-next = UnsafeTag . (+1) . unsafeUnTag--unsafeUnTag :: Tag -> Int-unsafeUnTag (UnsafeTag i) = i--tagWith :: Tag -> String -> String-tagWith t = appendShow (unsafeUnTag t) . (++ "_")--appendShow :: Show a => a -> String -> String-appendShow = flip (++) . show
− Opaleye/Internal/Unpackspec.hs
@@ -1,51 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}--module Opaleye.Internal.Unpackspec where--import qualified Opaleye.Internal.PackMap as PM-import qualified Opaleye.Internal.Column as IC-import qualified Opaleye.Column as C--import Control.Applicative (Applicative, pure, (<*>))-import Data.Profunctor (Profunctor, dimap)-import Data.Profunctor.Product (ProductProfunctor, empty, (***!))-import qualified Data.Profunctor.Product as PP-import qualified Data.Profunctor.Product.Default as D--import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ--newtype Unpackspec columns columns' =- Unpackspec (PM.PackMap HPQ.PrimExpr HPQ.PrimExpr columns columns')--unpackspecColumn :: Unpackspec (C.Column a) (C.Column a)-unpackspecColumn = Unpackspec- (PM.PackMap (\f (IC.Column pe) -> fmap IC.Column (f pe)))--runUnpackspec :: Applicative f- => Unpackspec columns b- -> (HPQ.PrimExpr -> f HPQ.PrimExpr)- -> columns -> f b-runUnpackspec (Unpackspec f) = PM.packmap f--instance D.Default Unpackspec (C.Column a) (C.Column a) where- def = unpackspecColumn---- {---- Boilerplate instance definitions. Theoretically, these are derivable.--instance Functor (Unpackspec a) where- fmap f (Unpackspec g) = Unpackspec (fmap f g)--instance Applicative (Unpackspec a) where- pure = Unpackspec . pure- Unpackspec f <*> Unpackspec x = Unpackspec (f <*> x)--instance Profunctor Unpackspec where- dimap f g (Unpackspec q) = Unpackspec (dimap f g q)--instance ProductProfunctor Unpackspec where- empty = PP.defaultEmpty- (***!) = PP.defaultProfunctorProduct----}
− Opaleye/Internal/Values.hs
@@ -1,98 +0,0 @@-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}--module Opaleye.Internal.Values where--import Opaleye.Internal.Column (Column(Column))--import qualified Opaleye.Internal.Unpackspec as U-import qualified Opaleye.Internal.Tag as T-import qualified Opaleye.Internal.PrimQuery as PQ-import qualified Opaleye.Internal.PackMap as PM-import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ--import Data.Profunctor (Profunctor, dimap, rmap)-import Data.Profunctor.Product (ProductProfunctor, empty, (***!))-import qualified Data.Profunctor.Product as PP-import Data.Profunctor.Product.Default (Default, def)--import Control.Applicative (Applicative, pure, (<*>))---- There are two annoyances with creating SQL VALUES statements------ 1. SQL does not allow empty VALUES statements so if we want to--- create a VALUES statement from an empty list we have to fake it--- somehow. The current approach is to make a VALUES statement--- with a single row of NULLs and then restrict it with WHERE--- FALSE.---- 2. Postgres's type inference of constants is pretty poor so we will--- sometimes have to give explicit type signatures. The future--- ShowConstant class will have the same problem. NB We don't--- actually currently address this problem.--valuesU :: U.Unpackspec columns columns'- -> Valuesspec columns columns'- -> [columns]- -> ((), T.Tag) -> (columns', PQ.PrimQuery, T.Tag)-valuesU unpack valuesspec rows ((), t) = (newColumns, primQ', T.next t)- where runRow row = valuesRow- where (_, valuesRow) =- PM.run (U.runUnpackspec unpack extractValuesEntry row)-- (newColumns, valuesPEs_nulls) =- PM.run (runValuesspec valuesspec (extractValuesField t))-- valuesPEs = map fst valuesPEs_nulls- nulls = map snd valuesPEs_nulls-- yieldNoRows :: PQ.PrimQuery -> PQ.PrimQuery- yieldNoRows = PQ.restrict (HPQ.ConstExpr (HPQ.BoolLit False))-- values' :: [[HPQ.PrimExpr]]- (values', wrap) = if null rows- then ([nulls], yieldNoRows)- else (map runRow rows, id)-- primQ' = wrap (PQ.Values valuesPEs values')---- We don't actually use the return value of this. It might be better--- to come up with another Applicative instance for specifically doing--- what we need.-extractValuesEntry :: HPQ.PrimExpr -> PM.PM [HPQ.PrimExpr] HPQ.PrimExpr-extractValuesEntry pe = do- PM.write pe- return pe--extractValuesField :: T.Tag -> HPQ.PrimExpr- -> PM.PM [(String, HPQ.PrimExpr)] HPQ.PrimExpr-extractValuesField = PM.extractAttr ("values" ++)--data Valuesspec columns columns' =- Valuesspec (PM.PackMap HPQ.PrimExpr HPQ.PrimExpr () columns')--runValuesspec :: Applicative f => Valuesspec columns columns'- -> (HPQ.PrimExpr -> f HPQ.PrimExpr) -> f columns'-runValuesspec (Valuesspec v) f = PM.packmap v f ()--instance Default Valuesspec (Column Int) (Column Int) where- def = Valuesspec (PM.PackMap (\f () -> fmap Column (f (HPQ.ConstExpr HPQ.NullLit))))---- {---- Boilerplate instance definitions. Theoretically, these are derivable.--instance Functor (Valuesspec a) where- fmap f (Valuesspec g) = Valuesspec (fmap f g)--instance Applicative (Valuesspec a) where- pure = Valuesspec . pure- Valuesspec f <*> Valuesspec x = Valuesspec (f <*> x)--instance Profunctor Valuesspec where- dimap _ g (Valuesspec q) = Valuesspec (rmap g q)--instance ProductProfunctor Valuesspec where- empty = PP.defaultEmpty- (***!) = PP.defaultProfunctorProduct---- }
− Opaleye/Join.hs
@@ -1,43 +0,0 @@-{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-}--module Opaleye.Join where--import qualified Opaleye.Internal.Unpackspec as U-import qualified Opaleye.Internal.Join as J-import qualified Opaleye.Internal.Tag as T-import qualified Opaleye.Internal.PrimQuery as PQ-import qualified Opaleye.Internal.PackMap as PM-import Opaleye.QueryArr (Query)-import qualified Opaleye.Internal.QueryArr as Q-import Opaleye.Internal.Column (Column(Column))--import qualified Data.Profunctor.Product.Default as D--leftJoin :: (D.Default U.Unpackspec columnsA columnsA,- D.Default U.Unpackspec columnsB columnsB,- D.Default J.NullMaker columnsB nullableColumnsB) =>- Query columnsA -> Query columnsB- -> ((columnsA, columnsB) -> Column Bool)- -> Query (columnsA, nullableColumnsB)-leftJoin = leftJoinExplicit D.def D.def D.def--leftJoinExplicit :: U.Unpackspec columnsA columnsA- -> U.Unpackspec columnsB columnsB- -> J.NullMaker columnsB nullableColumnsB- -> Query columnsA -> Query columnsB- -> ((columnsA, columnsB) -> Column Bool)- -> Query (columnsA, nullableColumnsB)-leftJoinExplicit unpackA unpackB nullmaker qA qB cond = Q.simpleQueryArr q where- q ((), startTag) = ((newColumnsA, nullableColumnsB), primQueryR, T.next endTag)- where (columnsA, primQueryA, midTag) = Q.runSimpleQueryArr qA ((), startTag)- (columnsB, primQueryB, endTag) = Q.runSimpleQueryArr qB ((), midTag)-- (newColumnsA, ljPEsA) =- PM.run (U.runUnpackspec unpackA (J.extractLeftJoinFields 1 endTag) columnsA)- (newColumnsB, ljPEsB) =- PM.run (U.runUnpackspec unpackB (J.extractLeftJoinFields 2 endTag) columnsB)-- nullableColumnsB = J.toNullable nullmaker newColumnsB-- Column cond' = cond (columnsA, columnsB)- primQueryR = PQ.Join PQ.LeftJoin (ljPEsA ++ ljPEsB) cond' primQueryA primQueryB
− Opaleye/Manipulation.hs
@@ -1,118 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}--module Opaleye.Manipulation where--import qualified Opaleye.Internal.Sql as Sql-import qualified Opaleye.Internal.Print as Print-import qualified Opaleye.RunQuery as RQ-import qualified Opaleye.Internal.RunQuery as IRQ-import qualified Opaleye.Table as T-import qualified Opaleye.Internal.Table as TI-import Opaleye.Internal.Column (Column(Column))-import Opaleye.Internal.Helpers ((.:), (.:.), (.::))-import qualified Opaleye.Internal.Unpackspec as U--import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ-import qualified Opaleye.Internal.HaskellDB.Sql as HSql-import qualified Opaleye.Internal.HaskellDB.Sql.Print as HPrint-import qualified Opaleye.Internal.HaskellDB.Sql.Default as SD-import qualified Opaleye.Internal.HaskellDB.Sql.Generate as SG--import qualified Database.PostgreSQL.Simple as PGS--import qualified Data.Profunctor.Product.Default as D--import Data.Int (Int64)-import Data.String (fromString)--arrangeInsert :: T.Table columns a -> columns -> HSql.SqlInsert-arrangeInsert (T.Table tableName (TI.TableProperties writer _)) columns = insert- where outColumns' = (map (\(x, y) -> (y, x))- . TI.runWriter writer) columns- insert = SG.sqlInsert SD.defaultSqlGenerator tableName outColumns'--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--arrangeUpdate :: T.Table columnsW columnsR- -> (columnsR -> columnsW) -> (columnsR -> Column Bool)- -> 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- Column condExpr = cond tableCols--arrangeUpdateSql :: T.Table columnsW columnsR- -> (columnsR -> columnsW) -> (columnsR -> Column Bool)- -> String-arrangeUpdateSql = show . HPrint.ppUpdate .:. arrangeUpdate--runUpdate :: PGS.Connection -> T.Table columnsW columnsR- -> (columnsR -> columnsW) -> (columnsR -> Column Bool)- -> IO Int64-runUpdate conn = PGS.execute_ conn . fromString .:. arrangeUpdateSql--arrangeDelete :: T.Table a columnsR -> (columnsR -> Column Bool) -> HSql.SqlDelete-arrangeDelete (TI.Table tableName (TI.TableProperties _ (TI.View tableCols)))- cond =- SG.sqlDelete SD.defaultSqlGenerator tableName [condExpr]- where Column condExpr = cond tableCols--arrangeDeleteSql :: T.Table a columnsR -> (columnsR -> Column Bool) -> String-arrangeDeleteSql = show . HPrint.ppDelete .: arrangeDelete--runDelete :: PGS.Connection -> T.Table a columnsR -> (columnsR -> Column Bool)- -> IO Int64-runDelete conn = PGS.execute_ conn . fromString .: arrangeDeleteSql--arrangeInsertReturning :: U.Unpackspec returned returned- -> T.Table columnsW columnsR- -> columnsW- -> (columnsR -> returned)- -> Sql.Returning HSql.SqlInsert-arrangeInsertReturning unpackspec table columns returningf =- Sql.Returning insert returningSEs- where insert = arrangeInsert table columns- TI.Table _ (TI.TableProperties _ (TI.View columnsR)) = table- returning = returningf columnsR- -- TODO: duplication with runQueryArrUnpack- f pe = ([pe], pe)- returningPEs :: [HPQ.PrimExpr]- (returningPEs, _) = U.runUnpackspec unpackspec f returning- returningSEs = map Sql.sqlExpr returningPEs--arrangeInsertReturningSql :: U.Unpackspec returned returned- -> T.Table columnsW columnsR- -> columnsW- -> (columnsR -> returned)- -> String-arrangeInsertReturningSql = show- . Print.ppInsertReturning- .:: arrangeInsertReturning--runInsertReturningExplicit :: RQ.QueryRunner returned haskells- -> U.Unpackspec returned returned- -> PGS.Connection- -> T.Table columnsW columnsR- -> columnsW- -> (columnsR -> returned)- -> IO [haskells]-runInsertReturningExplicit qr u conn = PGS.queryWith_ rowParser conn- . fromString- .:. arrangeInsertReturningSql u- where IRQ.QueryRunner _ rowParser = qr--runInsertReturning :: (D.Default RQ.QueryRunner returned haskells,- D.Default U.Unpackspec returned returned)- => PGS.Connection- -> T.Table columnsW columnsR- -> columnsW- -> (columnsR -> returned)- -> IO [haskells]-runInsertReturning = runInsertReturningExplicit D.def D.def
− Opaleye/Operators.hs
@@ -1,48 +0,0 @@-module Opaleye.Operators (module Opaleye.Operators,- (.==),- (.>),- case_,- ifThenElse) where--import Opaleye.Internal.Column (Column(Column), (.==), case_, (.>),- ifThenElse)-import qualified Opaleye.Internal.Column as C-import Opaleye.Internal.QueryArr (QueryArr(QueryArr))-import qualified Opaleye.Internal.PrimQuery as PQ--import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ--{-| Restrict query results to a particular condition. Corresponds to- the guard method of the MonadPlus class.--}-restrict :: QueryArr (Column Bool) ()-restrict = QueryArr f where- f (Column predicate, primQ, t0) = ((), PQ.restrict predicate primQ, t0)--doubleOfInt :: Column Int -> Column Double-doubleOfInt (Column e) = Column (HPQ.CastExpr "double precision" e)--(.<) :: Column a -> Column a -> Column Bool-(.<) = C.binOp HPQ.OpLt--(.<=) :: Column a -> Column a -> Column Bool-(.<=) = C.binOp HPQ.OpLtEq--(.>=) :: Column a -> Column a -> Column Bool-(.>=) = C.binOp HPQ.OpGtEq--(.&&) :: Column Bool -> Column Bool -> Column Bool-(.&&) = C.binOp HPQ.OpAnd--(.||) :: Column Bool -> Column Bool -> Column Bool-(.||) = C.binOp HPQ.OpOr--not :: Column Bool -> Column Bool-not = C.unOp HPQ.OpNot---- FIXME: Should we get rid of this and just use a monoid instance?-(.++) :: Column String -> Column String -> Column String-(.++) = C.binOp (HPQ.OpOther "||")--(./=) :: Column a -> Column a -> Column Bool-(./=) = C.binOp HPQ.OpNotEq
− Opaleye/Order.hs
@@ -1,35 +0,0 @@-module Opaleye.Order (module Opaleye.Order, O.Order) where--import qualified Opaleye.Column as C-import Opaleye.QueryArr (Query)-import qualified Opaleye.Internal.QueryArr as Q-import qualified Opaleye.Internal.Order as O--import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ--{-| Order the rows of a `Query` according to the `Order`. -}-orderBy :: O.Order a -> Query a -> Query a-orderBy os q =- Q.simpleQueryArr (O.orderByU os . Q.runSimpleQueryArr q)---- | Specify an ascending ordering by the given expression.-asc :: (a -> C.Column b) -> O.Order a-asc = O.order HPQ.OpAsc---- | Specify an descending ordering by the given expression.-desc :: (a -> C.Column b) -> O.Order a-desc = O.order HPQ.OpDesc--{- |-Limit the results of the given query to the given maximum number of-items.--}-limit :: Int -> Query a -> Query a-limit n a = Q.simpleQueryArr (O.limit' n . Q.runSimpleQueryArr a)--{- |-Offset the results of the given query by the given amount, skipping-that many result rows.--}-offset :: Int -> Query a -> Query a-offset n a = Q.simpleQueryArr (O.offset' n . Q.runSimpleQueryArr a)
− Opaleye/PGTypes.hs
@@ -1,53 +0,0 @@-module Opaleye.PGTypes where--import Opaleye.Internal.Column (Column(Column))-import qualified Opaleye.Internal.Column as C--import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ--import qualified Data.Text as Text-import qualified Data.Time as Time-import qualified Data.UUID as UUID-import qualified System.Locale as SL--literalColumn :: HPQ.Literal -> Column a-literalColumn = Column . HPQ.ConstExpr--pgString :: String -> Column String-pgString = literalColumn . HPQ.StringLit--pgText :: Text.Text -> Column String-pgText = literalColumn . HPQ.StringLit . Text.unpack--pgInt :: Int -> Column Int-pgInt = literalColumn . HPQ.IntegerLit . fromIntegral--pgInteger :: Integer -> Column Integer-pgInteger = literalColumn . HPQ.IntegerLit--pgDouble :: Double -> Column Double-pgDouble = literalColumn . HPQ.DoubleLit--pgBool :: Bool -> Column Bool-pgBool = literalColumn . HPQ.BoolLit--pgUUID :: UUID.UUID -> Column UUID.UUID-pgUUID = C.unsafeCoerce . pgString . UUID.toString--pgDay :: Time.Day -> Column Time.Day-pgDay = Column- . HPQ.CastExpr "date"- . HPQ.ConstExpr- . HPQ.OtherLit- . format- where formatString = "'%Y-%m-%d'"- format = Time.formatTime SL.defaultTimeLocale formatString--pgUTCTime :: Time.UTCTime -> Column Time.UTCTime-pgUTCTime = Column- . HPQ.CastExpr "timestamp"- . HPQ.ConstExpr- . HPQ.OtherLit- . format- where formatString = "'%Y-%m-%dT%H:%M:%SZ'"- format = Time.formatTime SL.defaultTimeLocale formatString
− Opaleye/QueryArr.hs
@@ -1,9 +0,0 @@-{-|--This modules defines the 'QueryArr' arrow, which is an arrow that represents-selecting data from a database, and composing multiple queries together.---}-module Opaleye.QueryArr (QueryArr, Query) where--import Opaleye.Internal.QueryArr (QueryArr, Query)
− Opaleye/RunQuery.hs
@@ -1,48 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}--module Opaleye.RunQuery (module Opaleye.RunQuery,- QueryRunner,- IRQ.QueryRunnerColumn) where--import qualified Database.PostgreSQL.Simple as PGS-import qualified Data.String as String---- It seems that we need the import of unsafeCoerce for Haddock-import Opaleye.Column (Column, unsafeCoerce)-import qualified Opaleye.Sql as S-import Opaleye.QueryArr (Query)-import Opaleye.Internal.RunQuery (QueryRunner(QueryRunner))-import qualified Opaleye.Internal.RunQuery as IRQ--import qualified Data.Profunctor as P-import qualified Data.Profunctor.Product.Default as D--runQuery :: D.Default QueryRunner columns haskells- => PGS.Connection- -> Query columns- -> IO [haskells]-runQuery = runQueryExplicit D.def--runQueryExplicit :: QueryRunner columns haskells- -> PGS.Connection- -> Query columns- -> IO [haskells]-runQueryExplicit (QueryRunner u rowParser) conn q =- PGS.queryWith_ rowParser conn sql- where sql :: PGS.Query- sql = String.fromString (S.showSqlForPostgresExplicit u q)---- | Use 'queryRunnerColumn' to make an instance to allow you to run queries on--- your own datatypes. For example:------ @--- newtype Foo = Foo Int--- instance Default QueryRunnerColumn Foo Foo where--- def = queryRunnerColumn ('unsafeCoerce' :: Column Foo -> Column Int) Foo def--- @-queryRunnerColumn :: (Column a' -> Column a) -> (b -> b')- -> IRQ.QueryRunnerColumn a b -> IRQ.QueryRunnerColumn a' b'-queryRunnerColumn colF haskellF qrc = IRQ.QueryRunnerColumn (P.lmap colF u)- (fmapFP haskellF fp)- where IRQ.QueryRunnerColumn u fp = qrc- fmapFP = fmap . fmap . fmap
− Opaleye/Sql.hs
@@ -1,36 +0,0 @@-{-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-}--module Opaleye.Sql where--import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ--import qualified Opaleye.Internal.Unpackspec as U-import qualified Opaleye.Internal.Sql as Sql-import qualified Opaleye.Internal.Print as Pr-import qualified Opaleye.Internal.PrimQuery as PQ-import qualified Opaleye.Internal.Optimize as Op-import Opaleye.Internal.Helpers ((.:))-import qualified Opaleye.Internal.QueryArr as Q--import qualified Data.Profunctor.Product.Default as D--import qualified Control.Arrow as Arr--showSqlForPostgres :: forall columns . D.Default U.Unpackspec columns columns =>- Q.Query columns -> String-showSqlForPostgres = showSqlForPostgresExplicit (D.def :: U.Unpackspec columns columns)--showSqlForPostgresUnopt :: forall columns . D.Default U.Unpackspec columns columns =>- Q.Query columns -> String-showSqlForPostgresUnopt = showSqlForPostgresUnoptExplicit (D.def :: U.Unpackspec columns columns)--showSqlForPostgresExplicit :: U.Unpackspec columns b -> Q.Query columns -> String-showSqlForPostgresExplicit = formatAndShowSQL- . Arr.first Op.optimize- .: Q.runQueryArrUnpack--showSqlForPostgresUnoptExplicit :: U.Unpackspec columns b -> Q.Query columns -> String-showSqlForPostgresUnoptExplicit = formatAndShowSQL .: Q.runQueryArrUnpack--formatAndShowSQL :: (PQ.PrimQuery, [HPQ.PrimExpr]) -> String-formatAndShowSQL = show . Pr.ppSql . Sql.sql
− Opaleye/Table.hs
@@ -1,43 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}--module Opaleye.Table (module Opaleye.Table,- View,- Writer,- Table(Table),- TableProperties) where--import Opaleye.Internal.Column (Column(Column))-import qualified Opaleye.Internal.QueryArr as Q-import qualified Opaleye.Internal.Table as T-import Opaleye.Internal.Table (View(View), Writer(Writer),- Table, TableProperties)-import qualified Opaleye.Internal.TableMaker as TM-import qualified Opaleye.Internal.Tag as Tag-import qualified Opaleye.Internal.PackMap as PM--import qualified Data.Profunctor.Product.Default as D-import Control.Applicative (Applicative, pure)--import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ--queryTable :: D.Default TM.ColumnMaker columns columns =>- Table a columns -> Q.Query columns-queryTable = queryTableExplicit D.def--queryTableExplicit :: TM.ColumnMaker tablecolumns columns ->- Table a tablecolumns -> Q.Query columns-queryTableExplicit cm table = Q.simpleQueryArr f where- f ((), t0) = (retwires, primQ, Tag.next t0) where- (retwires, primQ) = T.queryTable cm table t0--required :: String -> TableProperties (Column a) (Column a)-required columnName = T.TableProperties- (Writer (PM.PackMap (\f (Column primExpr) -> f (primExpr, columnName))))- (View (Column (HPQ.AttrExpr columnName)))--optional :: String -> TableProperties (Maybe (Column a)) (Column a)-optional columnName = T.TableProperties- (Writer (PM.PackMap (\f c -> case c of- Nothing -> pure ()- Just (Column primExpr) -> f (primExpr, columnName))))- (View (Column (HPQ.AttrExpr columnName)))
− Opaleye/Values.hs
@@ -1,21 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}--module Opaleye.Values where--import qualified Opaleye.Internal.QueryArr as Q-import Opaleye.QueryArr (Query)-import Opaleye.Internal.Values as V-import qualified Opaleye.Internal.Unpackspec as U--import Data.Profunctor.Product.Default (Default, def)--values :: (Default V.Valuesspec columns columns,- Default U.Unpackspec columns columns) =>- [columns] -> Q.Query columns-values = valuesExplicit def def--valuesExplicit :: U.Unpackspec columns columns'- -> V.Valuesspec columns columns'- -> [columns] -> Query columns'-valuesExplicit unpack valuesspec columns =- Q.simpleQueryArr (V.valuesU unpack valuesspec columns)
+ README.md view
@@ -0,0 +1,72 @@+# Brief introduction to Opaleye++Opaleye is a Haskell library which provides an SQL-generating embedded+domain specific language for targeting Postgres. You need Opaleye if+you want to use Haskell to write typesafe and composable code to query+a Postgres database.++Opaleye allows you to define your database tables and write queries+against them in Haskell code, and aims to be typesafe in the sense+that if your code compiles then the generated SQL query will not fail+at runtime. A wide range of SQL functionality is supported including+inner and outer joins, restriction, aggregation, distinct, sorting and+limiting, unions and differences. Facilities to insert to, update and+delete from tables are also provided. Code written using Opaleye is+composable at a very fine level of granularity, promoting code reuse+and high levels of abstraction.++## Tutorials++Please get started with Opaleye by referring to these two tutorials++* [Basic tutorial](Doc/Tutorial/TutorialBasic.lhs)+* [Manipulation tutorial](Doc/Tutorial/TutorialManipulation.lhs)++# Contact++## Contact the author++The main author of Opaleye is Tom Ellis. He can be [contacted via+email](http://web.jaguarpaw.co.uk/~tom/contact/).++## File bugs++Please file bugs on the [Opaleye GitHub issue tracking+page](https://github.com/tomjaguarpaw/haskell-opaleye/issues/).++## Mailing list++Please join the [opaleye-users mailing+list](https://lists.sourceforge.net/lists/listinfo/opaleye-users).++# `Internal` modules++Opaleye exports a number of modules named `Opaleye.Internal....`.+They are provided in case of urgent need for access to the internals,+but they are not intended to be used by API consumers and if you find+yourself repeatedly accessing them this is a sign that either you or+Opaleye are doing something wrong. In such a case please file a bug.++The interface of `Internal` modules does not follow the PVP and may+break between minor releases, so be careful.++# Commercial support++Commercial support for Opaleye is provided by [Purely+Agile](http://www.purelyagile.com/).++# Contributors++The Opaleye Project was founded by Tom Ellis, inspired by theoretical+work on databases by David Spivak. Much of the implementation was+based on ideas and code from the HaskellDB project by Daan Leijen,+Conny Andersson, Martin Andersson, Mary Bergman, Victor Blomqvist,+Bjorn Bringert, Anders Hockersten, Torbjorn Martin, Jeremy Shaw and+Justin Bailey.++Silk (Erik Hesselink, Adam Bergmark), Karamaan (Christopher Lewis),+Fynder (Renzo Carbonara, Oliver Charles) and Daniel Patterson+contributed code to the project.++Joseph Abrahamson, Alfredo Di Napoli and Mietek Bak performed useful+reviews of early versions which helped improve the codebase.
+ TODO.md view
@@ -0,0 +1,28 @@+# Low priority++* General type families for improving instance resolution (product-profunctors)++## Good starter projects for someone wanting to contribute to Opaleye++### Very easy++* There may be some missing operators that just need to be written down+* RIGHT JOIN, FULL OUTER JOIN+* Set operations+ * EXCEPT+ * EXCEPT ALL+ * UNION+ * INTERSECT+ * INTERSECT ALL+* INSERT, UPDATE, DELETE RETURNING+* Improve the testing "framework" perhaps by upgrading it to Tasty++### Require a bit of work++* Make the code generation neater+* Make VALUES work with more, type checked, value types+* Product-valued case statements+* Make the test database parameters more easily configurable+* Randomised testing in a QuickCheck style+* distinct, union and aggregate can be made to work with QueryArr+ rather than just Query if we use LATERAL JOIN
Test/Test.hs view
@@ -3,20 +3,8 @@ module Main where -import qualified Opaleye.Table as T-import Opaleye.Column (Column, Nullable)-import qualified Opaleye.Column as C-import Opaleye.Operators ((.==), (.>))-import qualified Opaleye.Operators as O-import Opaleye.QueryArr (Query, QueryArr)-import qualified Opaleye.RunQuery as RQ-import qualified Opaleye.Order as Order-import qualified Opaleye.Distinct as Dis-import qualified Opaleye.Aggregate as Agg-import qualified Opaleye.Join as J-import qualified Opaleye.Values as V-import qualified Opaleye.Binary as B-import qualified Opaleye.Manipulation as M+import Opaleye (Column, Nullable, Query, QueryArr, (.==), (.>))+import qualified Opaleye as O import qualified Database.PostgreSQL.Simple as PGS import qualified Data.Profunctor.Product.Default as D@@ -118,32 +106,32 @@ -} twoIntTable :: String- -> T.Table (Column Int, Column Int) (Column Int, Column Int)-twoIntTable n = T.Table n (PP.p2 (T.required "column1", T.required "column2"))+ -> O.Table (Column O.PGInt4, Column O.PGInt4) (Column O.PGInt4, Column O.PGInt4)+twoIntTable n = O.Table n (PP.p2 (O.required "column1", O.required "column2")) -table1 :: T.Table (Column Int, Column Int) (Column Int, Column Int)+table1 :: O.Table (Column O.PGInt4, Column O.PGInt4) (Column O.PGInt4, Column O.PGInt4) table1 = twoIntTable "table1" -table1F :: T.Table (Column Int, Column Int) (Column Int, Column Int)+table1F :: O.Table (Column O.PGInt4, Column O.PGInt4) (Column O.PGInt4, Column O.PGInt4) table1F = fmap (\(col1, col2) -> (col1 + col2, col1 - col2)) table1 -table2 :: T.Table (Column Int, Column Int) (Column Int, Column Int)+table2 :: O.Table (Column O.PGInt4, Column O.PGInt4) (Column O.PGInt4, Column O.PGInt4) table2 = twoIntTable "table2" -table3 :: T.Table (Column Int, Column Int) (Column Int, Column Int)+table3 :: O.Table (Column O.PGInt4, Column O.PGInt4) (Column O.PGInt4, Column O.PGInt4) table3 = twoIntTable "table3" -table4 :: T.Table (Column Int, Column Int) (Column Int, Column Int)+table4 :: O.Table (Column O.PGInt4, Column O.PGInt4) (Column O.PGInt4, Column O.PGInt4) table4 = twoIntTable "table4" -table1Q :: Query (Column Int, Column Int)-table1Q = T.queryTable table1+table1Q :: Query (Column O.PGInt4, Column O.PGInt4)+table1Q = O.queryTable table1 -table2Q :: Query (Column Int, Column Int)-table2Q = T.queryTable table2+table2Q :: Query (Column O.PGInt4, Column O.PGInt4)+table2Q = O.queryTable table2 -table3Q :: Query (Column Int, Column Int)-table3Q = T.queryTable table3+table3Q :: Query (Column O.PGInt4, Column O.PGInt4)+table3Q = O.queryTable table3 table1dataG :: Num a => [(a, a)] table1dataG = [ (1, 100)@@ -154,7 +142,7 @@ table1data :: [(Int, Int)] table1data = table1dataG -table1columndata :: [(Column Int, Column Int)]+table1columndata :: [(Column O.PGInt4, Column O.PGInt4)] table1columndata = table1dataG table2dataG :: Num a => [(a, a)]@@ -164,7 +152,7 @@ table2data :: [(Int, Int)] table2data = table2dataG -table2columndata :: [(Column Int, Column Int)]+table2columndata :: [(Column O.PGInt4, Column O.PGInt4)] table2columndata = table2dataG table3dataG :: Num a => [(a, a)]@@ -173,7 +161,7 @@ table3data :: [(Int, Int)] table3data = table3dataG -table3columndata :: [(Column Int, Column Int)]+table3columndata :: [(Column O.PGInt4, Column O.PGInt4)] table3columndata = table3dataG table4dataG :: Num a => [(a, a)]@@ -183,7 +171,7 @@ table4data :: [(Int, Int)] table4data = table4dataG -table4columndata :: [(Column Int, Column Int)]+table4columndata :: [(Column O.PGInt4, Column O.PGInt4)] table4columndata = table4dataG dropAndCreateTable :: String -> PGS.Query@@ -197,13 +185,13 @@ type Test = PGS.Connection -> IO Bool -testG :: D.Default RQ.QueryRunner wires haskells =>+testG :: D.Default O.QueryRunner wires haskells => Query wires -> ([haskells] -> b) -> PGS.Connection -> IO b testG q p conn = do- result <- RQ.runQuery conn q+ result <- O.runQuery conn q return (p result) testSelect :: Test@@ -225,7 +213,7 @@ testNum :: Test testNum = testG query expected- where query :: Query (Column Int)+ where query :: Query (Column O.PGInt4) query = proc () -> do t <- table1Q -< () Arr.returnA -< op t@@ -235,7 +223,7 @@ testDiv :: Test testDiv = testG query expected- where query :: Query (Column Double)+ where query :: Query (Column O.PGFloat8) query = proc () -> do t <- Arr.arr (O.doubleOfInt *** O.doubleOfInt) <<< table1Q -< () Arr.returnA -< op t@@ -250,120 +238,120 @@ -- TODO: need to implement and test case_ returning tuples testCase :: Test testCase = testG q (== expected)- where q :: Query (Column Int)+ where q :: Query (Column O.PGInt4) q = table1Q >>> proc (i, j) -> do Arr.returnA -< O.case_ [(j .== 100, 12), (i .== 1, 21)] 33 expected :: [Int] expected = [12, 12, 21, 33] testDistinct :: Test-testDistinct = testG (Dis.distinct table1Q)+testDistinct = testG (O.distinct table1Q) (\r -> L.sort (L.nub table1data) == L.sort r) -- FIXME: the unsafeCoerce is currently needed because the type -- changes required for aggregation are not currently dealt with by -- Opaleye.-aggregateCoerceFIXME :: QueryArr (Column Int) (Column Int64)+aggregateCoerceFIXME :: QueryArr (Column O.PGInt4) (Column O.PGInt8) aggregateCoerceFIXME = Arr.arr aggregateCoerceFIXME' -aggregateCoerceFIXME' :: Column a -> Column Int64-aggregateCoerceFIXME' = C.unsafeCoerce+aggregateCoerceFIXME' :: Column a -> Column O.PGInt8+aggregateCoerceFIXME' = O.unsafeCoerce testAggregate :: Test testAggregate = testG (Arr.second aggregateCoerceFIXME- <<< Agg.aggregate (PP.p2 (Agg.groupBy, Agg.sum))+ <<< O.aggregate (PP.p2 (O.groupBy, O.sum)) table1Q) (\r -> [(1, 400) :: (Int, Int64), (2, 300)] == L.sort r) testAggregateProfunctor :: Test testAggregateProfunctor = testG q expected- where q = Agg.aggregate (PP.p2 (Agg.groupBy, countsum)) table1Q+ where q = O.aggregate (PP.p2 (O.groupBy, countsum)) table1Q expected r = [(1, 1200) :: (Int, Int64), (2, 300)] == L.sort r countsum = P.dimap (\x -> (x,x)) (\(x, y) -> aggregateCoerceFIXME' x * y)- (PP.p2 (Agg.sum, Agg.count))+ (PP.p2 (O.sum, O.count)) -testOrderByG :: Order.Order (Column Int, Column Int)+testOrderByG :: O.Order (Column O.PGInt4, Column O.PGInt4) -> ((Int, Int) -> (Int, Int) -> Ordering) -> Test-testOrderByG orderQ order = testG (Order.orderBy orderQ table1Q)+testOrderByG orderQ order = testG (O.orderBy orderQ table1Q) (L.sortBy order table1data ==) testOrderBy :: Test-testOrderBy = testOrderByG (Order.desc snd)+testOrderBy = testOrderByG (O.desc snd) (flip (Ord.comparing snd)) testOrderBy2 :: Test-testOrderBy2 = testOrderByG (Order.desc fst <> Order.asc snd)+testOrderBy2 = testOrderByG (O.desc fst <> O.asc snd) (flip (Ord.comparing fst) <> Ord.comparing snd) testOrderBySame :: Test-testOrderBySame = testOrderByG (Order.desc fst <> Order.asc fst)+testOrderBySame = testOrderByG (O.desc fst <> O.asc fst) (flip (Ord.comparing fst) <> Ord.comparing fst) -testLOG :: (Query (Column Int, Column Int) -> Query (Column Int, Column Int))+testLOG :: (Query (Column O.PGInt4, Column O.PGInt4) -> Query (Column O.PGInt4, Column O.PGInt4)) -> ([(Int, Int)] -> [(Int, Int)]) -> Test testLOG olQ ol = testG (olQ (orderQ table1Q)) (ol (order table1data) ==)- where orderQ = Order.orderBy (Order.desc snd)+ where orderQ = O.orderBy (O.desc snd) order = L.sortBy (flip (Ord.comparing snd)) testLimit :: Test-testLimit = testLOG (Order.limit 2) (take 2)+testLimit = testLOG (O.limit 2) (take 2) testOffset :: Test-testOffset = testLOG (Order.offset 2) (drop 2)+testOffset = testLOG (O.offset 2) (drop 2) testLimitOffset :: Test-testLimitOffset = testLOG (Order.limit 2 . Order.offset 2) (take 2 . drop 2)+testLimitOffset = testLOG (O.limit 2 . O.offset 2) (take 2 . drop 2) testOffsetLimit :: Test-testOffsetLimit = testLOG (Order.offset 2 . Order.limit 2) (drop 2 . take 2)+testOffsetLimit = testLOG (O.offset 2 . O.limit 2) (drop 2 . take 2) testDistinctAndAggregate :: Test testDistinctAndAggregate = testG q expected- where q = Dis.distinct table1Q+ where q = O.distinct table1Q &&& (Arr.second aggregateCoerceFIXME- <<< Agg.aggregate (PP.p2 (Agg.groupBy, Agg.sum)) table1Q)+ <<< O.aggregate (PP.p2 (O.groupBy, O.sum)) table1Q) expected r = L.sort r == L.sort expectedResult expectedResult = A.liftA2 (,) (L.nub table1data) [(1 :: Int, 400 :: Int64), (2, 300)] -one :: Query (Column Int)-one = Arr.arr (const (1 :: Column Int))+one :: Query (Column O.PGInt4)+one = Arr.arr (const (1 :: Column O.PGInt4)) -- The point of the "double" tests is to ensure that we do not -- introduce name clashes in the operations which create new column names-testDoubleG :: (Eq haskells, D.Default RQ.QueryRunner columns haskells) =>- (QueryArr () (Column Int) -> QueryArr () columns) -> [haskells]+testDoubleG :: (Eq haskells, D.Default O.QueryRunner columns haskells) =>+ (QueryArr () (Column O.PGInt4) -> QueryArr () columns) -> [haskells] -> Test testDoubleG q expected1 = testG (q one &&& q one) (== expected2) where expected2 = A.liftA2 (,) expected1 expected1 testDoubleDistinct :: Test-testDoubleDistinct = testDoubleG Dis.distinct [1 :: Int]+testDoubleDistinct = testDoubleG O.distinct [1 :: Int] testDoubleAggregate :: Test-testDoubleAggregate = testDoubleG (Agg.aggregate Agg.count) [1 :: Int64]+testDoubleAggregate = testDoubleG (O.aggregate O.count) [1 :: Int64] testDoubleLeftJoin :: Test testDoubleLeftJoin = testDoubleG lj [(1 :: Int, Just (1 :: Int))]- where lj :: Query (Column Int)- -> Query (Column Int, Column (Nullable Int))- lj q = J.leftJoin q q (uncurry (.==))+ where lj :: Query (Column O.PGInt4)+ -> Query (Column O.PGInt4, Column (Nullable O.PGInt4))+ lj q = O.leftJoin q q (uncurry (.==)) testDoubleValues :: Test testDoubleValues = testDoubleG v [1 :: Int]- where v :: Query (Column Int) -> Query (Column Int)- v _ = V.values [1]+ where v :: Query (Column O.PGInt4) -> Query (Column O.PGInt4)+ v _ = O.values [1] testDoubleUnionAll :: Test testDoubleUnionAll = testDoubleG u [1 :: Int, 1]- where u q = q `B.unionAll` q+ where u q = q `O.unionAll` q -aLeftJoin :: Query ((Column Int, Column Int),- (Column (Nullable Int), Column (Nullable Int)))-aLeftJoin = J.leftJoin table1Q table3Q (\(l, r) -> fst l .== fst r)+aLeftJoin :: Query ((Column O.PGInt4, Column O.PGInt4),+ (Column (Nullable O.PGInt4), Column (Nullable O.PGInt4)))+aLeftJoin = O.leftJoin table1Q table3Q (\(l, r) -> fst l .== fst r) testLeftJoin :: Test testLeftJoin = testG aLeftJoin (== expected)@@ -375,11 +363,11 @@ testLeftJoinNullable :: Test testLeftJoinNullable = testG q (== expected)- where q :: Query ((Column Int, Column Int),- ((Column (Nullable Int), Column (Nullable Int)),- (Column (Nullable Int),- Column (Nullable Int))))- q = J.leftJoin table3Q aLeftJoin cond+ where q :: Query ((Column O.PGInt4, Column O.PGInt4),+ ((Column (Nullable O.PGInt4), Column (Nullable O.PGInt4)),+ (Column (Nullable O.PGInt4),+ Column (Nullable O.PGInt4))))+ q = O.leftJoin table3Q aLeftJoin cond cond (x, y) = fst x .== fst (fst y) @@ -394,8 +382,8 @@ expected = A.liftA3 (,,) table1data table2data table3data testValues :: Test-testValues = testG (V.values values) (values' ==)- where values :: [(Column Int, Column Int)]+testValues = testG (O.values values) (values' ==)+ where values :: [(Column O.PGInt4, Column O.PGInt4)] values = [ (1, 10) , (2, 100) ] values' :: [(Int, Int)]@@ -404,8 +392,8 @@ {- FIXME: does not yet work testValuesDouble :: Test-testValuesDouble = testG (V.values values) (values' ==)- where values :: [(Column Int, Column Double)]+testValuesDouble = testG (O.values values) (values' ==)+ where values :: [(Column O.PGInt4, Column O.PGFloat8)] values = [ (1, 10.0) , (2, 100.0) ] values' :: [(Int, Double)]@@ -414,36 +402,36 @@ -} testValuesEmpty :: Test-testValuesEmpty = testG (V.values values) (values' ==)- where values :: [Column Int]+testValuesEmpty = testG (O.values values) (values' ==)+ where values :: [Column O.PGInt4] values = [] values' :: [Int] values' = [] testUnionAll :: Test-testUnionAll = testG (table1Q `B.unionAll` table2Q)+testUnionAll = testG (table1Q `O.unionAll` table2Q) (\r -> L.sort (table1data ++ table2data) == L.sort r) testTableFunctor :: Test-testTableFunctor = testG (T.queryTable table1F) (result ==)+testTableFunctor = testG (O.queryTable table1F) (result ==) where result = fmap (\(col1, col2) -> (col1 + col2, col1 - col2)) table1data -- TODO: This is getting too complicated testUpdate :: Test testUpdate conn = do- _ <- M.runUpdate conn table4 update cond+ _ <- O.runUpdate conn table4 update cond result <- runQueryTable4 if result /= expected then return False else do- _ <- M.runDelete conn table4 condD+ _ <- O.runDelete conn table4 condD resultD <- runQueryTable4 if resultD /= expectedD then return False else do- returned <- M.runInsertReturning conn table4 insertT returning+ returned <- O.runInsertReturning conn table4 insertT returning resultI <- runQueryTable4 return ((resultI == expectedI) && (returned == expectedR))@@ -456,9 +444,9 @@ , (22, -18)] expectedD :: [(Int, Int)] expectedD = [(1, 10)]- runQueryTable4 = RQ.runQuery conn (T.queryTable table4)+ runQueryTable4 = O.runQuery conn (O.queryTable table4) - insertT :: (Column Int, Column Int)+ insertT :: (Column O.PGInt4, Column O.PGInt4) insertT = (1, 2) expectedI :: [(Int, Int)]@@ -486,7 +474,7 @@ dropAndCreateDB conn let insert (writeable, columndata) =- mapM_ (M.runInsert conn writeable) columndata+ mapM_ (O.runInsert conn writeable) columndata mapM_ insert [ (table1, table1columndata) , (table2, table2columndata)
opaleye.cabal view
@@ -1,37 +1,41 @@-name: opaleye-version: 0.2-synopsis: An SQL-generating DSL targeting PostgreSQL-description: An SQL-generating DSL targeting PostgreSQL. Allows- Postgres queries to be written within Haskell in a- typesafe and composable fashion.-homepage: https://github.com/tomjaguarpaw/haskell-opaleye-license: BSD3-license-File: LICENSE-author: Purely Agile-maintainer: Purely Agile-category: Database-build-type: Simple-cabal-version: >= 1.8+name: opaleye+version: 0.3+synopsis: An SQL-generating DSL targeting PostgreSQL+description: An SQL-generating DSL targeting PostgreSQL. Allows+ Postgres queries to be written within Haskell in a+ typesafe and composable fashion.+homepage: https://github.com/tomjaguarpaw/haskell-opaleye+license: BSD3+license-File: LICENSE+author: Purely Agile+maintainer: Purely Agile+category: Database+build-type: Simple+cabal-version: >= 1.8+extra-doc-files: *.md,+ Doc/*.md source-repository head Type: git Location: https://github.com/tomjaguarpaw/haskell-opaleye library+ hs-source-dirs: src build-depends: base >= 4 && < 5 , contravariant >= 0.4.4 && < 1.3 , old-locale >= 1.0 && < 1.1 , postgresql-simple >= 0.3 && < 0.5 , pretty >= 1.1.1.0 && < 1.2- , product-profunctors >= 0.5 && < 0.6- , profunctors >= 4.0 && < 4.3+ , product-profunctors >= 0.5 && < 0.7+ , profunctors >= 4.0 && < 4.4 , semigroups >= 0.13 && < 0.16- , text >= 0.11 && < 1.2+ , text >= 0.11 && < 1.3 , transformers >= 0.3 && < 0.4 , time >= 1.4 && < 1.5 , uuid >= 1.3 && < 1.4- exposed-modules: Opaleye.Aggregate,+ exposed-modules: Opaleye,+ Opaleye.Aggregate, Opaleye.Binary, Opaleye.Column, Opaleye.Distinct,@@ -65,7 +69,6 @@ Opaleye.Internal.Unpackspec, Opaleye.Internal.Values Opaleye.Internal.HaskellDB.PrimQuery,- Opaleye.Internal.HaskellDB.Query, Opaleye.Internal.HaskellDB.Sql, Opaleye.Internal.HaskellDB.Sql.Default, Opaleye.Internal.HaskellDB.Sql.Generate,@@ -87,12 +90,15 @@ test-suite tutorial type: exitcode-stdio-1.0 main-is: Main.hs+ other-modules: TutorialAdvanced,+ TutorialBasic,+ TutorialManipulation hs-source-dirs: Doc/Tutorial build-depends: base >= 4 && < 5, postgresql-simple, profunctors,- product-profunctors,+ product-profunctors >= 0.6, time, opaleye ghc-options: -Wall
+ src/Opaleye.hs view
@@ -0,0 +1,30 @@+module Opaleye ( module Opaleye.Aggregate+ , module Opaleye.Binary+ , module Opaleye.Column+ , module Opaleye.Distinct+ , module Opaleye.Join+ , module Opaleye.Manipulation+ , module Opaleye.Operators+ , module Opaleye.Order+ , module Opaleye.PGTypes+ , module Opaleye.QueryArr+ , module Opaleye.RunQuery+ , module Opaleye.Sql+ , module Opaleye.Table+ , module Opaleye.Values+ ) where++import Opaleye.Aggregate+import Opaleye.Binary+import Opaleye.Column+import Opaleye.Distinct+import Opaleye.Join+import Opaleye.Manipulation+import Opaleye.Operators+import Opaleye.Order+import Opaleye.PGTypes+import Opaleye.QueryArr+import Opaleye.RunQuery+import Opaleye.Sql+import Opaleye.Table+import Opaleye.Values
+ src/Opaleye/Aggregate.hs view
@@ -0,0 +1,53 @@+-- | Perform aggregations on query results.+module Opaleye.Aggregate (module Opaleye.Aggregate, Aggregator) where++import qualified Opaleye.Internal.Aggregate as A+import Opaleye.Internal.Aggregate (Aggregator)+import Opaleye.QueryArr (Query)+import qualified Opaleye.Internal.QueryArr as Q+import qualified Opaleye.Column as C+import qualified Opaleye.PGTypes as T+import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ++-- This page of Postgres documentation tell us what aggregate+-- functions are available+--+-- http://www.postgresql.org/docs/9.3/static/functions-aggregate.html++{-|+Given a 'Query' producing rows of type @a@ and an 'Aggregator' accepting rows of+type @a@, apply the aggregator to the results of the query.++-}+aggregate :: Aggregator a b -> Query a -> Query b+aggregate agg q = Q.simpleQueryArr (A.aggregateU agg . Q.runSimpleQueryArr q)++-- | Group the aggregation by equality on the input to 'groupBy'.+groupBy :: Aggregator (C.Column a) (C.Column a)+groupBy = A.makeAggr' Nothing++-- | Sum all rows in a group.+sum :: Aggregator (C.Column a) (C.Column a)+sum = A.makeAggr HPQ.AggrSum++-- | Count the number of non-null rows in a group.+count :: Aggregator (C.Column a) (C.Column T.PGInt8)+count = A.makeAggr HPQ.AggrCount++-- | Average of a group+avg :: Aggregator (C.Column T.PGFloat8) (C.Column T.PGFloat8)+avg = A.makeAggr HPQ.AggrAvg++-- | Maximum of a group+max :: Aggregator (C.Column a) (C.Column a)+max = A.makeAggr HPQ.AggrMax++-- | Maximum of a group+min :: Aggregator (C.Column a) (C.Column a)+min = A.makeAggr HPQ.AggrMin++boolOr :: Aggregator (C.Column T.PGBool) (C.Column T.PGBool)+boolOr = A.makeAggr HPQ.AggrBoolOr++boolAnd :: Aggregator (C.Column T.PGBool) (C.Column T.PGBool)+boolAnd = A.makeAggr HPQ.AggrBoolAnd
+ src/Opaleye/Binary.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts #-}++module Opaleye.Binary where++import Opaleye.QueryArr (Query)+import qualified Opaleye.Internal.QueryArr as Q+import qualified Opaleye.Internal.Binary as B+import qualified Opaleye.Internal.Tag as T+import qualified Opaleye.Internal.PrimQuery as PQ+import qualified Opaleye.Internal.PackMap as PM++import Data.Profunctor.Product.Default (Default, def)++-- | Example type specialization:+--+-- @+-- unionAll :: Query (Column a, Column b)+-- -> Query (Column a, Column b)+-- -> Query (Column a, Column b)+-- @+--+-- Assuming the @makeAdaptorAndInstance@ splice has been run for the product type @Foo@:+--+-- @+-- unionAll :: Query (Foo (Column a) (Column b) (Column c))+-- -> Query (Foo (Column a) (Column b) (Column c))+-- -> Query (Foo (Column a) (Column b) (Column c))+-- @+unionAll :: Default B.Binaryspec columns columns =>+ Query columns -> Query columns -> Query columns+unionAll = unionAllExplicit def++unionAllExplicit :: B.Binaryspec columns columns'+ -> Query columns -> Query columns -> Query columns'+unionAllExplicit binaryspec q1 q2 = Q.simpleQueryArr q where+ q ((), startTag) = (newColumns, newPrimQuery, T.next endTag)+ where (columns1, primQuery1, midTag) = Q.runSimpleQueryArr q1 ((), startTag)+ (columns2, primQuery2, endTag) = Q.runSimpleQueryArr q2 ((), midTag)++ (newColumns, pes) =+ PM.run (B.runBinaryspec binaryspec (B.extractBinaryFields endTag)+ (columns1, columns2))++ newPrimQuery = PQ.Binary PQ.UnionAll pes (primQuery1, primQuery2)
+ src/Opaleye/Column.hs view
@@ -0,0 +1,50 @@+module Opaleye.Column (module Opaleye.Column,+ Column,+ Nullable,+ unsafeCoerce) where++import Opaleye.Internal.Column (Column, Nullable, unsafeCoerce)+import qualified Opaleye.Internal.Column as C+import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ+import qualified Opaleye.PGTypes as T+import Prelude hiding (null)++-- | A NULL of any type+null :: Column (Nullable a)+null = unsafeCoerce (C.Column (HPQ.ConstExpr HPQ.NullLit))++isNull :: Column (Nullable a) -> Column T.PGBool+isNull = C.unOp HPQ.OpIsNull++-- | If the @Column (Nullable a)@ is NULL then return the @Column b@+-- otherwise map the underlying @Column a@ using the provided+-- function.+--+-- The Opaleye equivalent of the 'Data.Maybe.maybe' function.+matchNullable :: Column b -> (Column a -> Column b) -> Column (Nullable a)+ -> Column b+matchNullable replacement f x = C.unsafeIfThenElse (isNull x) replacement+ (f (unsafeCoerce x))++-- | If the @Column (Nullable a)@ is NULL then return the provided+-- @Column a@ otherwise return the underlying @Column a@.+--+-- The Opaleye equivalent of the 'Data.Maybe.fromMaybe' function+fromNullable :: Column a -> Column (Nullable a) -> Column a+fromNullable = flip matchNullable id++-- | The Opaleye equivalent of 'Data.Maybe.Just'+toNullable :: Column a -> Column (Nullable a)+toNullable = unsafeCoerce++-- | If the argument is 'Data.Maybe.Nothing' return NULL otherwise return the+-- provided value coerced to a nullable type.+maybeToNullable :: Maybe (Column a) -> Column (Nullable a)+maybeToNullable = maybe null toNullable++-- | Cast a column to any other type. This is safe for some conversions such as uuid to text.+unsafeCast :: String -> C.Column a -> Column b+unsafeCast = mapColumn . HPQ.CastExpr+ where+ mapColumn :: (HPQ.PrimExpr -> HPQ.PrimExpr) -> Column c -> Column a+ mapColumn primExpr c = C.Column (primExpr (C.unColumn c))
+ src/Opaleye/Distinct.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE FlexibleContexts #-}++module Opaleye.Distinct (module Opaleye.Distinct, distinctExplicit)+ where++import Opaleye.QueryArr (Query)+import Opaleye.Internal.Distinct (distinctExplicit, Distinctspec)++import qualified Data.Profunctor.Product.Default as D++-- | Remove duplicate items from the query result.+--+-- Example type specialization:+--+-- @+-- distinct :: Query (Column a, Column b) -> Query (Column a, Column b)+-- @+--+-- Assuming the @makeAdaptorAndInstance@ splice has been run for the product type @Foo@:+--+-- @+-- distinct :: Query (Foo (Column a) (Column b) (Column c)) -> Query (Foo (Column a) (Column b) (Column c))+-- @+distinct :: D.Default Distinctspec columns columns =>+ Query columns -> Query columns+distinct = distinctExplicit D.def
+ src/Opaleye/Internal/Aggregate.hs view
@@ -0,0 +1,63 @@+module Opaleye.Internal.Aggregate where++import Control.Applicative (Applicative, pure, (<*>))++import qualified Data.Profunctor as P+import qualified Data.Profunctor.Product as PP++import qualified Opaleye.Internal.PackMap as PM+import qualified Opaleye.Internal.PrimQuery as PQ+import qualified Opaleye.Internal.Tag as T+import qualified Opaleye.Internal.Column as C++import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ++{-|+An 'Aggregator' takes a collection of rows of type @a@, groups+them, and transforms each group into a single row of type @b@. This+corresponds to aggregators using @GROUP BY@ in SQL.+-}+newtype Aggregator a b = Aggregator+ (PM.PackMap (Maybe HPQ.AggrOp, HPQ.PrimExpr) HPQ.PrimExpr+ a b)++makeAggr' :: Maybe HPQ.AggrOp -> Aggregator (C.Column a) (C.Column b)+makeAggr' m = Aggregator (PM.PackMap+ (\f (C.Column e) -> fmap C.Column (f (m, e))))++makeAggr :: HPQ.AggrOp -> Aggregator (C.Column a) (C.Column b)+makeAggr = makeAggr' . Just++runAggregator :: Applicative f => Aggregator a b+ -> ((Maybe HPQ.AggrOp, HPQ.PrimExpr) -> f HPQ.PrimExpr) -> a -> f b+runAggregator (Aggregator a) = PM.packmap a++aggregateU :: Aggregator a b+ -> (a, PQ.PrimQuery, T.Tag) -> (b, PQ.PrimQuery, T.Tag)+aggregateU agg (c0, primQ, t0) = (c1, primQ', T.next t0)+ where (c1, projPEs) =+ PM.run (runAggregator agg (extractAggregateFields t0) c0)++ primQ' = PQ.Aggregate projPEs primQ++extractAggregateFields :: T.Tag -> (Maybe HPQ.AggrOp, HPQ.PrimExpr)+ -> PM.PM [(HPQ.Symbol, (Maybe HPQ.AggrOp, HPQ.PrimExpr))] HPQ.PrimExpr+extractAggregateFields = PM.extractAttr "result"++-- { Boilerplate instances++instance Functor (Aggregator a) where+ fmap f (Aggregator g) = Aggregator (fmap f g)++instance Applicative (Aggregator a) where+ pure = Aggregator . pure+ Aggregator f <*> Aggregator x = Aggregator (f <*> x)++instance P.Profunctor Aggregator where+ dimap f g (Aggregator q) = Aggregator (P.dimap f g q)++instance PP.ProductProfunctor Aggregator where+ empty = PP.defaultEmpty+ (***!) = PP.defaultProfunctorProduct++-- }
+ src/Opaleye/Internal/Binary.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts #-}++module Opaleye.Internal.Binary where++import Opaleye.Internal.Column (Column(Column))+import qualified Opaleye.Internal.Tag as T+import qualified Opaleye.Internal.PackMap as PM++import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ++import Data.Profunctor (Profunctor, dimap)+import Data.Profunctor.Product (ProductProfunctor, empty, (***!))+import qualified Data.Profunctor.Product as PP+import Data.Profunctor.Product.Default (Default, def)++import Control.Applicative (Applicative, pure, (<*>))+import Control.Arrow ((***))++extractBinaryFields :: T.Tag -> (HPQ.PrimExpr, HPQ.PrimExpr)+ -> PM.PM [(HPQ.Symbol, (HPQ.PrimExpr, HPQ.PrimExpr))]+ HPQ.PrimExpr+extractBinaryFields = PM.extractAttr "binary"++data Binaryspec columns columns' =+ Binaryspec (PM.PackMap (HPQ.PrimExpr, HPQ.PrimExpr) HPQ.PrimExpr+ (columns, columns) columns')++runBinaryspec :: Applicative f => Binaryspec columns columns'+ -> ((HPQ.PrimExpr, HPQ.PrimExpr) -> f HPQ.PrimExpr)+ -> (columns, columns) -> f columns'+runBinaryspec (Binaryspec b) = PM.packmap b++instance Default Binaryspec (Column a) (Column a) where+ def = Binaryspec (PM.PackMap (\f (Column e, Column e')+ -> fmap Column (f (e, e'))))++-- {++-- Boilerplate instance definitions. Theoretically, these are derivable.++instance Functor (Binaryspec a) where+ fmap f (Binaryspec g) = Binaryspec (fmap f g)++instance Applicative (Binaryspec a) where+ pure = Binaryspec . pure+ Binaryspec f <*> Binaryspec x = Binaryspec (f <*> x)++instance Profunctor Binaryspec where+ dimap f g (Binaryspec b) = Binaryspec (dimap (f *** f) g b)++instance ProductProfunctor Binaryspec where+ empty = PP.defaultEmpty+ (***!) = PP.defaultProfunctorProduct++-- }
+ src/Opaleye/Internal/Column.hs view
@@ -0,0 +1,59 @@+module Opaleye.Internal.Column where++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.+newtype Column a = Column HPQ.PrimExpr deriving Show++data Nullable a = Nullable++unColumn :: Column a -> HPQ.PrimExpr+unColumn (Column e) = e++unsafeCoerce :: Column a -> Column b+unsafeCoerce (Column e) = Column e++binOp :: HPQ.BinOp -> Column a -> Column b -> Column c+binOp op (Column e) (Column e') = Column (HPQ.BinExpr op e e')++unOp :: HPQ.UnOp -> Column a -> Column b+unOp op (Column e) = Column (HPQ.UnExpr op e)++-- For import order reasons we can't make the return type PGBool+unsafeCase_ :: [(Column pgBool, Column a)] -> Column a -> Column a+unsafeCase_ alts (Column otherwise_) = Column (HPQ.CaseExpr (unColumns alts) otherwise_)+ where unColumns = map (\(Column e, Column e') -> (e, e'))++unsafeIfThenElse :: Column pgBool -> Column a -> Column a -> Column a+unsafeIfThenElse cond t f = unsafeCase_ [(cond, t)] f++unsafeGt :: Column a -> Column a -> Column pgBool+unsafeGt = binOp HPQ.OpGt++unsafeEq :: Column a -> Column a -> Column pgBool+unsafeEq = binOp HPQ.OpEq++class PGNum a where+ pgFromInteger :: Integer -> Column a++instance PGNum a => Num (Column a) where+ fromInteger = pgFromInteger+ (*) = binOp HPQ.OpMul+ (+) = binOp HPQ.OpPlus+ (-) = binOp HPQ.OpMinus++ abs = unOp HPQ.OpAbs+ negate = unOp HPQ.OpNegate++ -- We can't use Postgres's 'sign' function because it returns only a+ -- numeric or a double+ signum c = unsafeCase_ [(c `unsafeGt` 0, 1), (c `unsafeEq` 0, 0)] (-1)++class PGFractional a where+ pgFromRational :: Rational -> Column a++instance (PGNum a, PGFractional a) => Fractional (Column a) where+ fromRational = pgFromRational+ (/) = binOp HPQ.OpDiv
+ src/Opaleye/Internal/Distinct.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE MultiParamTypeClasses #-}++module Opaleye.Internal.Distinct where++import Opaleye.QueryArr (Query)+import Opaleye.Column (Column)+import Opaleye.Aggregate (Aggregator, groupBy, aggregate)++import Control.Applicative (Applicative, pure, (<*>))++import qualified Data.Profunctor as P+import qualified Data.Profunctor.Product as PP+import Data.Profunctor.Product.Default (Default, def)++-- We implement distinct simply by grouping by all columns. We could+-- instead implement it as SQL's DISTINCT but implementing it in terms+-- of something else that we already have is easier at this point.++distinctExplicit :: Distinctspec columns columns'+ -> Query columns -> Query columns'+distinctExplicit (Distinctspec agg) = aggregate agg++data Distinctspec a b = Distinctspec (Aggregator a b)++instance Default Distinctspec (Column a) (Column a) where+ def = Distinctspec groupBy++-- { Boilerplate instances++instance Functor (Distinctspec a) where+ fmap f (Distinctspec g) = Distinctspec (fmap f g)++instance Applicative (Distinctspec a) where+ pure = Distinctspec . pure+ Distinctspec f <*> Distinctspec x = Distinctspec (f <*> x)++instance P.Profunctor Distinctspec where+ dimap f g (Distinctspec q) = Distinctspec (P.dimap f g q)++instance PP.ProductProfunctor Distinctspec where+ empty = PP.defaultEmpty+ (***!) = PP.defaultProfunctorProduct++-- }
+ src/Opaleye/Internal/HaskellDB/PrimQuery.hs view
@@ -0,0 +1,71 @@+-- Copyright : Daan Leijen (c) 1999, daan@cs.uu.nl+-- HWT Group (c) 2003, haskelldb-users@lists.sourceforge.net+-- License : BSD-style++module Opaleye.Internal.HaskellDB.PrimQuery where++import qualified Opaleye.Internal.Tag as T++type TableName = String+type Attribute = String+type Name = String+type Scheme = [Attribute]+type Assoc = [(Attribute,PrimExpr)]++data Symbol = Symbol String T.Tag deriving (Read, Show)++data PrimExpr = AttrExpr Symbol+ | BaseTableAttrExpr Attribute+ | BinExpr BinOp PrimExpr PrimExpr+ | UnExpr UnOp PrimExpr+ | AggrExpr AggrOp PrimExpr+ | 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+ | DefaultLit -- ^ represents a default value+ | BoolLit Bool+ | StringLit String+ | IntegerLit Integer+ | DoubleLit Double+ | OtherLit String -- ^ used for hacking in custom SQL+ deriving (Read,Show)++data BinOp = OpEq | OpLt | OpLtEq | OpGt | OpGtEq | OpNotEq + | OpAnd | OpOr+ | OpLike | OpIn + | OpOther String++ | OpCat+ | OpPlus | OpMinus | OpMul | OpDiv | OpMod+ | OpBitNot | OpBitAnd | OpBitOr | OpBitXor+ | OpAsg+ deriving (Show,Read)++data UnOp = OpNot+ | OpIsNull+ | OpIsNotNull+ | OpLength+ | OpAbs+ | OpNegate+ | OpLower+ | OpUpper+ | UnOpOther String+ deriving (Show,Read)++data AggrOp = AggrCount | AggrSum | AggrAvg | AggrMin | AggrMax+ | AggrStdDev | AggrStdDevP | AggrVar | AggrVarP+ | AggrBoolOr | AggrBoolAnd+ | AggrOther String+ deriving (Show,Read)++data OrderExpr = OrderExpr OrderOp PrimExpr + deriving (Show)++data OrderOp = OpAsc | OpDesc+ deriving (Show)
+ src/Opaleye/Internal/HaskellDB/Sql.hs view
@@ -0,0 +1,56 @@+-- Copyright : Daan Leijen (c) 1999, daan@cs.uu.nl+-- HWT Group (c) 2003, haskelldb-users@lists.sourceforge.net+-- License : BSD-style++module Opaleye.Internal.HaskellDB.Sql ( + SqlTable,+ SqlColumn(..),+ SqlName,+ SqlOrder(..),++ SqlUpdate(..), + SqlDelete(..), + SqlInsert(..), ++ SqlExpr(..),+ ) where+++-----------------------------------------------------------+-- * SQL data type+-----------------------------------------------------------++type SqlTable = String++newtype SqlColumn = SqlColumn String deriving Show++-- | A valid SQL name for a parameter.+type SqlName = String++data SqlOrder = SqlAsc | SqlDesc+ deriving Show++-- | Expressions in SQL statements.+data SqlExpr = ColumnSqlExpr SqlColumn+ | BinSqlExpr String SqlExpr SqlExpr+ | PrefixSqlExpr String SqlExpr+ | PostfixSqlExpr String SqlExpr+ | FunSqlExpr String [SqlExpr]+ | AggrFunSqlExpr String [SqlExpr] -- ^ Aggregate functions separate from normal functions.+ | ConstSqlExpr String+ | CaseSqlExpr [(SqlExpr,SqlExpr)] SqlExpr+ | ListSqlExpr [SqlExpr]+ | ParamSqlExpr (Maybe SqlName) SqlExpr+ | PlaceHolderSqlExpr+ | ParensSqlExpr SqlExpr+ | CastSqlExpr String SqlExpr + deriving Show++-- | Data type for SQL UPDATE statements.+data SqlUpdate = SqlUpdate SqlTable [(SqlColumn,SqlExpr)] [SqlExpr]++-- | Data type for SQL DELETE statements.+data SqlDelete = SqlDelete SqlTable [SqlExpr]++--- | Data type for SQL INSERT statements.+data SqlInsert = SqlInsert SqlTable [SqlColumn] [SqlExpr]
+ src/Opaleye/Internal/HaskellDB/Sql/Default.hs view
@@ -0,0 +1,197 @@+-- Copyright : Daan Leijen (c) 1999, daan@cs.uu.nl+-- HWT Group (c) 2003, haskelldb-users@lists.sourceforge.net+-- License : BSD-style++module Opaleye.Internal.HaskellDB.Sql.Default where++import Opaleye.Internal.HaskellDB.PrimQuery+import Opaleye.Internal.HaskellDB.Sql+import Opaleye.Internal.HaskellDB.Sql.Generate+import Opaleye.Internal.Tag (tagWith)++mkSqlGenerator :: SqlGenerator -> SqlGenerator+mkSqlGenerator gen = SqlGenerator + {+ sqlUpdate = defaultSqlUpdate gen,+ sqlDelete = defaultSqlDelete gen,+ sqlInsert = defaultSqlInsert gen,+ sqlExpr = defaultSqlExpr gen,+ sqlLiteral = defaultSqlLiteral gen,+ sqlQuote = defaultSqlQuote gen+ }++defaultSqlGenerator :: SqlGenerator+defaultSqlGenerator = mkSqlGenerator defaultSqlGenerator+++toSqlOrder :: SqlGenerator -> OrderExpr -> (SqlExpr,SqlOrder)+toSqlOrder gen (OrderExpr o e) = (sqlExpr gen e, o')+ where o' = case o of+ OpAsc -> SqlAsc+ OpDesc -> SqlDesc++toSqlAssoc :: SqlGenerator -> Assoc -> [(SqlColumn,SqlExpr)]+toSqlAssoc gen = map (\(attr,expr) -> (SqlColumn attr, sqlExpr gen expr))+++defaultSqlUpdate :: SqlGenerator + -> TableName -- ^ Name of the 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 name (toSqlAssoc gen assigns) (map (sqlExpr gen) criteria) +++defaultSqlInsert :: SqlGenerator + -> TableName -- ^ Name of the table+ -> Assoc -- ^ What to insert.+ -> SqlInsert+defaultSqlInsert gen table assoc = SqlInsert table cs es+ where (cs,es) = unzip (toSqlAssoc gen assoc)+++defaultSqlDelete :: SqlGenerator + -> TableName -- ^ Name of the table+ -> [PrimExpr] -- ^ Criteria which must all be true for a row+ -- to be deleted.+ -> SqlDelete+defaultSqlDelete gen name criteria = SqlDelete name (map (sqlExpr gen) criteria)+++defaultSqlExpr :: SqlGenerator -> PrimExpr -> SqlExpr+defaultSqlExpr gen expr = + case expr of+ AttrExpr (Symbol a t) -> ColumnSqlExpr (SqlColumn (tagWith t a))+ BaseTableAttrExpr a -> ColumnSqlExpr (SqlColumn a)+ BinExpr op e1 e2 ->+ let leftE = sqlExpr gen e1+ rightE = sqlExpr gen e2+ paren = ParensSqlExpr+ (expL, expR) = case (op, e1, e2) of+ (OpAnd, BinExpr OpOr _ _, BinExpr OpOr _ _) ->+ (paren leftE, paren rightE)+ (OpOr, BinExpr OpAnd _ _, BinExpr OpAnd _ _) ->+ (paren leftE, paren rightE)+ (OpAnd, BinExpr OpOr _ _, _) ->+ (paren leftE, rightE)+ (OpAnd, _, BinExpr OpOr _ _) ->+ (leftE, paren rightE)+ (OpOr, BinExpr OpAnd _ _, _) ->+ (paren leftE, rightE)+ (OpOr, _, BinExpr OpAnd _ _) ->+ (leftE, paren 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' (ParensSqlExpr e')+ UnOpPostfix -> PostfixSqlExpr op' e'+ AggrExpr op e -> let op' = showAggrOp op+ e' = sqlExpr gen e+ in AggrFunSqlExpr op' [e']+ ConstExpr l -> ConstSqlExpr (sqlLiteral gen l)+ CaseExpr cs e -> let cs' = [(sqlExpr gen c, sqlExpr gen x)| (c,x) <- cs] + e' = sqlExpr gen e+ in CaseSqlExpr cs' e'+ ListExpr es -> ListSqlExpr (map (sqlExpr gen) es)+ ParamExpr n _ -> 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 = "=" +showBinOp OpLt = "<" +showBinOp OpLtEq = "<=" +showBinOp OpGt = ">" +showBinOp OpGtEq = ">=" +showBinOp OpNotEq = "<>" +showBinOp OpAnd = "AND" +showBinOp OpOr = "OR" +showBinOp OpLike = "LIKE" +showBinOp OpIn = "IN" +showBinOp (OpOther s) = s+showBinOp OpCat = "||" +showBinOp OpPlus = "+" +showBinOp OpMinus = "-" +showBinOp OpMul = "*" +showBinOp OpDiv = "/" +showBinOp OpMod = "MOD" +showBinOp OpBitNot = "~" +showBinOp OpBitAnd = "&" +showBinOp OpBitOr = "|" +showBinOp OpBitXor = "^"+showBinOp OpAsg = "="+++data UnOpType = UnOpFun | UnOpPrefix | UnOpPostfix++sqlUnOp :: UnOp -> (String,UnOpType)+sqlUnOp OpNot = ("NOT", UnOpPrefix)+sqlUnOp OpIsNull = ("IS NULL", UnOpPostfix)+sqlUnOp OpIsNotNull = ("IS NOT NULL", UnOpPostfix)+sqlUnOp OpLength = ("LENGTH", UnOpFun)+sqlUnOp OpAbs = ("@", UnOpFun)+sqlUnOp OpNegate = ("-", UnOpFun)+sqlUnOp OpLower = ("LOWER", UnOpFun)+sqlUnOp OpUpper = ("UPPER", UnOpFun)+sqlUnOp (UnOpOther s) = (s, UnOpFun)+++showAggrOp :: AggrOp -> String+showAggrOp AggrCount = "COUNT" +showAggrOp AggrSum = "SUM" +showAggrOp AggrAvg = "AVG" +showAggrOp AggrMin = "MIN" +showAggrOp AggrMax = "MAX" +showAggrOp AggrStdDev = "StdDev" +showAggrOp AggrStdDevP = "StdDevP" +showAggrOp AggrVar = "Var" +showAggrOp AggrVarP = "VarP" +showAggrOp AggrBoolAnd = "BOOL_AND"+showAggrOp AggrBoolOr = "BOOL_OR"+showAggrOp (AggrOther s) = s+++defaultSqlLiteral :: SqlGenerator -> Literal -> String+defaultSqlLiteral _ l = + case l of+ NullLit -> "NULL"+ DefaultLit -> "DEFAULT"+ BoolLit True -> "TRUE"+ BoolLit False -> "FALSE"+ StringLit s -> quote s+ IntegerLit i -> show i+ DoubleLit d -> show d+ OtherLit o -> o+++defaultSqlQuote :: SqlGenerator -> String -> String+defaultSqlQuote _ s = quote s++-- | Quote a string and escape characters that need escaping+-- We use Postgres "escape strings", i.e. strings prefixed+-- with E, to ensure that escaping with backslash is valid.+quote :: String -> String +quote s = "E'" ++ concatMap escape s ++ "'"++-- | Escape characters that need escaping+escape :: Char -> String+escape '\NUL' = "\\0"+escape '\'' = "''"+escape '"' = "\\\""+escape '\b' = "\\b"+escape '\n' = "\\n"+escape '\r' = "\\r"+escape '\t' = "\\t"+escape '\\' = "\\\\"+escape c = [c]
+ src/Opaleye/Internal/HaskellDB/Sql/Generate.hs view
@@ -0,0 +1,21 @@+-- Copyright : Daan Leijen (c) 1999, daan@cs.uu.nl+-- HWT Group (c) 2003, haskelldb-users@lists.sourceforge.net+-- License : BSD-style++module Opaleye.Internal.HaskellDB.Sql.Generate (SqlGenerator(..)) where++import Opaleye.Internal.HaskellDB.PrimQuery+import Opaleye.Internal.HaskellDB.Sql+++data SqlGenerator = SqlGenerator+ {+ sqlUpdate :: TableName -> [PrimExpr] -> Assoc -> SqlUpdate,+ sqlDelete :: TableName -> [PrimExpr] -> SqlDelete,+ sqlInsert :: TableName -> Assoc -> SqlInsert,+ sqlExpr :: PrimExpr -> SqlExpr,+ sqlLiteral :: Literal -> String,+ -- | Turn a string into a quoted string. Quote characters+ -- and any escaping are handled by this function.+ sqlQuote :: String -> String+ }
+ src/Opaleye/Internal/HaskellDB/Sql/Print.hs view
@@ -0,0 +1,106 @@+-- Copyright : Daan Leijen (c) 1999, daan@cs.uu.nl+-- HWT Group (c) 2003, haskelldb-users@lists.sourceforge.net+-- License : BSD-style++module Opaleye.Internal.HaskellDB.Sql.Print ( + ppUpdate,+ ppDelete, + ppInsert,+ ppSqlExpr,+ ppWhere,+ ppGroupBy,+ ppOrderBy,+ ppAs,+ commaV,+ commaH+ ) where++import Opaleye.Internal.HaskellDB.Sql (SqlColumn(..), SqlDelete(..),+ SqlExpr(..), SqlOrder(..), SqlInsert(..),+ SqlUpdate(..))++import Data.List (intersperse)+import Text.PrettyPrint.HughesPJ (Doc, (<+>), ($$), (<>), comma, empty, equals,+ hcat, hsep, parens, punctuate, text, vcat)+++ppWhere :: [SqlExpr] -> Doc+ppWhere [] = empty+ppWhere es = text "WHERE" + <+> hsep (intersperse (text "AND")+ (map (parens . ppSqlExpr) es))++ppGroupBy :: [SqlExpr] -> Doc+ppGroupBy es = text "GROUP BY" <+> ppGroupAttrs es+ where+ ppGroupAttrs :: [SqlExpr] -> Doc+ ppGroupAttrs cs = commaV nameOrExpr cs+ nameOrExpr :: SqlExpr -> Doc+ nameOrExpr (ColumnSqlExpr (SqlColumn col)) = text col+ nameOrExpr expr = parens (ppSqlExpr expr)+ +ppOrderBy :: [(SqlExpr,SqlOrder)] -> Doc+ppOrderBy [] = empty+ppOrderBy ord = text "ORDER BY" <+> commaV ppOrd ord+ where+ ppOrd (e,o) = ppSqlExpr e <+> ppSqlOrder o+ ppSqlOrder :: SqlOrder -> Doc+ ppSqlOrder SqlAsc = text "ASC"+ ppSqlOrder SqlDesc = text "DESC"++ppAs :: String -> Doc -> Doc+ppAs alias expr | null alias = expr + | otherwise = expr <+> (hsep . map text) ["as",alias]+++ppUpdate :: SqlUpdate -> Doc+ppUpdate (SqlUpdate name assigns criteria)+ = text "UPDATE" <+> text name+ $$ text "SET" <+> commaV ppAssign assigns+ $$ ppWhere criteria+ where+ ppAssign (c,e) = ppColumn c <+> equals <+> ppSqlExpr e+++ppDelete :: SqlDelete -> Doc+ppDelete (SqlDelete name criteria) =+ text "DELETE FROM" <+> text name $$ ppWhere criteria+++ppInsert :: SqlInsert -> Doc++ppInsert (SqlInsert table names values)+ = text "INSERT INTO" <+> text table + <+> parens (commaV ppColumn names)+ $$ text "VALUES" <+> parens (commaV ppSqlExpr values)++ppColumn :: SqlColumn -> Doc+ppColumn (SqlColumn s) = text s+++ppSqlExpr :: SqlExpr -> Doc+ppSqlExpr expr =+ case expr of+ ColumnSqlExpr c -> ppColumn c+ 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)+ AggrFunSqlExpr f es -> text f <> parens (commaH ppSqlExpr es)+ ConstSqlExpr c -> text c+ CaseSqlExpr cs el -> text "CASE" <+> vcat (map ppWhen cs)+ <+> text "ELSE" <+> ppSqlExpr el <+> text "END"+ where ppWhen (w,t) = text "WHEN" <+> ppSqlExpr w + <+> text "THEN" <+> ppSqlExpr t+ ListSqlExpr es -> parens (commaH ppSqlExpr es)+ ParamSqlExpr _ v -> ppSqlExpr v+ PlaceHolderSqlExpr -> text "?"+ CastSqlExpr typ e -> text "CAST" <> parens (ppSqlExpr e <+> text "AS" <+> text typ)+ ++commaH :: (a -> Doc) -> [a] -> Doc+commaH f = hcat . punctuate comma . map f++commaV :: (a -> Doc) -> [a] -> Doc+commaV f = vcat . punctuate comma . map f
+ src/Opaleye/Internal/Helpers.hs view
@@ -0,0 +1,16 @@+module Opaleye.Internal.Helpers where++infixr 8 .:++(.:) :: (r -> z) -> (a -> b -> r) -> a -> b -> z+(.:) f g x y = f (g x y)++infixr 8 .:.++(.:.) :: (r -> z) -> (a -> b -> c -> r) -> a -> b -> c -> z+(.:.) f g a b c = f (g a b c)++infixr 8 .::++(.::) :: (r -> z) -> (a -> b -> c -> d -> r) -> a -> b -> c -> d -> z+(.::) f g a b c d = f (g a b c d)
+ src/Opaleye/Internal/Join.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-}++module Opaleye.Internal.Join where++import qualified Opaleye.Internal.Tag as T+import qualified Opaleye.Internal.PackMap as PM+import Opaleye.Internal.Column (Column, Nullable)+import qualified Opaleye.Column as C++import Data.Profunctor (Profunctor, dimap)+import Data.Profunctor.Product (ProductProfunctor, empty, (***!))+import qualified Data.Profunctor.Product.Default as D++import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ++data NullMaker a b = NullMaker (a -> b)++toNullable :: NullMaker a b -> a -> b+toNullable (NullMaker f) = f++extractLeftJoinFields :: Int -> T.Tag -> HPQ.PrimExpr+ -> PM.PM [(HPQ.Symbol, HPQ.PrimExpr)] HPQ.PrimExpr+extractLeftJoinFields n = PM.extractAttr ("result" ++ show n ++ "_")++instance D.Default NullMaker (Column a) (Column (Nullable a)) where+ def = NullMaker C.unsafeCoerce++instance D.Default NullMaker (Column (Nullable a)) (Column (Nullable a)) where+ def = NullMaker C.unsafeCoerce++-- { Boilerplate instances++instance Profunctor NullMaker where+ dimap f g (NullMaker h) = NullMaker (dimap f g h)++instance ProductProfunctor NullMaker where+ empty = NullMaker empty+ NullMaker f ***! NullMaker f' = NullMaker (f ***! f')++--
+ src/Opaleye/Internal/Optimize.hs view
@@ -0,0 +1,31 @@+module Opaleye.Internal.Optimize where++import Prelude hiding (product)++import qualified Opaleye.Internal.PrimQuery as PQ++import qualified Data.List.NonEmpty as NEL++optimize :: PQ.PrimQuery -> PQ.PrimQuery+optimize = mergeProduct . removeUnit++removeUnit :: PQ.PrimQuery -> PQ.PrimQuery+removeUnit = PQ.foldPrimQuery (PQ.Unit, PQ.BaseTable, product, PQ.Aggregate,+ PQ.Order, PQ.Limit, PQ.Join, PQ.Values,+ PQ.Binary)+ where product pqs pes = PQ.Product pqs' pes+ where pqs' = case NEL.filter (not . PQ.isUnit) pqs of+ [] -> return PQ.Unit+ xs -> NEL.fromList xs++mergeProduct :: PQ.PrimQuery -> PQ.PrimQuery+mergeProduct = PQ.foldPrimQuery (PQ.Unit, PQ.BaseTable, product, PQ.Aggregate,+ PQ.Order, PQ.Limit, PQ.Join, PQ.Values,+ PQ.Binary)+ where product pqs pes = PQ.Product pqs' (pes ++ pes')+ where pqs' = pqs >>= queries+ queries (PQ.Product qs _) = qs+ queries q = return q+ pes' = NEL.toList pqs >>= conds+ conds (PQ.Product _ cs) = cs+ conds _ = []
+ src/Opaleye/Internal/Order.hs view
@@ -0,0 +1,47 @@+module Opaleye.Internal.Order where++import qualified Opaleye.Column as C+import qualified Opaleye.Internal.Column as IC+import qualified Opaleye.Internal.Tag as T+import qualified Opaleye.Internal.PrimQuery as PQ++import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ+import qualified Data.Functor.Contravariant as C+import qualified Data.Profunctor as P+import qualified Data.Monoid as M++data SingleOrder a = SingleOrder HPQ.OrderOp (a -> HPQ.PrimExpr)++instance C.Contravariant SingleOrder where+ contramap f (SingleOrder op g) = SingleOrder op (P.lmap f g)++{-|+An `Order` represents an expression to order on and a sort+direction. Multiple `Order`s can be composed with+`Data.Monoid.mappend`. If two rows are equal according to the first+`Order`, the second is used, and so on.+-}+newtype Order a = Order [SingleOrder a]++instance C.Contravariant Order where+ contramap f (Order xs) = Order (fmap (C.contramap f) xs)++instance M.Monoid (Order a) where+ mempty = Order M.mempty+ Order o `mappend` Order o' = Order (o `M.mappend` o')++order :: HPQ.OrderOp -> (a -> C.Column b) -> Order a+order op f = C.contramap f (Order [SingleOrder op IC.unColumn])++orderByU :: Order a -> (a, PQ.PrimQuery, T.Tag) -> (a, PQ.PrimQuery, T.Tag)+orderByU os (columns, primQ, t) = (columns, primQ', t)+ where primQ' = PQ.Order orderExprs primQ+ Order sos = os+ orderExprs = map (\(SingleOrder op f)+ -> HPQ.OrderExpr op (f columns)) sos++limit' :: Int -> (a, PQ.PrimQuery, T.Tag) -> (a, PQ.PrimQuery, T.Tag)+limit' n (x, q, t) = (x, PQ.Limit (PQ.LimitOp n) q, t)++offset' :: Int -> (a, PQ.PrimQuery, T.Tag) -> (a, PQ.PrimQuery, T.Tag)+offset' n (x, q, t) = (x, PQ.Limit (PQ.OffsetOp n) q, t)
+ src/Opaleye/Internal/PackMap.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE Rank2Types #-}++module Opaleye.Internal.PackMap where++import qualified Opaleye.Internal.Tag as T++import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ++import Control.Applicative (Applicative, pure, (<*>), liftA2)+import qualified Control.Monad.Trans.State as State+import Data.Profunctor (Profunctor, dimap)+import Data.Profunctor.Product (ProductProfunctor, empty, (***!))+import qualified Data.Profunctor.Product as PP+import qualified Data.Functor.Identity as I++-- This is rather like a Control.Lens.Traversal with the type+-- parameters switched but I'm not sure if it should be required to+-- obey the same laws.+--+-- TODO: We could attempt to generalise this to+--+-- data LensLike f a b s t = LensLike ((a -> f b) -> s -> f t)+--+-- i.e. a wrapped, argument-flipped Control.Lens.LensLike+--+-- This would allow us to do the Profunctor and ProductProfunctor+-- instances (requiring just Functor f and Applicative f respectively)+-- and share them between many different restrictions of f. For+-- example, TableColumnMaker is like a Setter so we would restrict f+-- to the Distributive case.+data PackMap a b s t = PackMap (Applicative f =>+ (a -> f b) -> s -> f t)++packmap :: Applicative f => PackMap a b s t -> (a -> f b) -> s -> f t+packmap (PackMap f) = f++over :: PackMap a b s t -> (a -> b) -> s -> t+over p f = I.runIdentity . packmap p (I.Identity . f)+++-- { A helpful monad for writing columns in the AST++type PM a = State.State (a, Int)++new :: PM a String+new = do+ (a, i) <- State.get+ State.put (a, i + 1)+ return (show i)++write :: a -> PM [a] ()+write a = do+ (as, i) <- State.get+ State.put (as ++ [a], i)++run :: PM [a] r -> (r, [a])+run m = (r, as)+ where (r, (as, _)) = State.runState m ([], 0)++-- }+++-- { General functions for writing columns in the AST++-- This one ignores the 'a' when making the internal column name.+extractAttr :: String -> T.Tag -> a+ -> PM [(HPQ.Symbol, a)] HPQ.PrimExpr+extractAttr s = extractAttrPE (const (s ++))++-- This one can make the internal column name depend on the 'a' in+-- question (probably a PrimExpr)+extractAttrPE :: (a -> String -> String) -> T.Tag -> a+ -> PM [(HPQ.Symbol, a)] HPQ.PrimExpr+extractAttrPE mkName t pe = do+ i <- new+ let s = HPQ.Symbol (mkName pe i) t+ write (s, pe)+ return (HPQ.AttrExpr s)++-- }+++-- {++-- Boilerplate instance definitions. There's no choice here apart+-- from the order in which the applicative is applied.++instance Functor (PackMap a b s) where+ fmap f (PackMap g) = PackMap ((fmap . fmap . fmap) f g)++instance Applicative (PackMap a b s) where+ pure x = PackMap (pure (pure (pure x)))+ PackMap f <*> PackMap x = PackMap (liftA2 (liftA2 (<*>)) f x)++instance Profunctor (PackMap a b) where+ dimap f g (PackMap q) = PackMap (fmap (dimap f (fmap g)) q)++instance ProductProfunctor (PackMap a b) where+ empty = PP.defaultEmpty+ (***!) = PP.defaultProfunctorProduct++-- }
+ src/Opaleye/Internal/PrimQuery.hs view
@@ -0,0 +1,65 @@+module Opaleye.Internal.PrimQuery where++import Prelude hiding (product)++import qualified Data.List.NonEmpty as NEL+import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ+import Opaleye.Internal.HaskellDB.PrimQuery (Symbol)++data LimitOp = LimitOp Int | OffsetOp Int | LimitOffsetOp Int Int+ deriving Show++data BinOp = Except | Union | UnionAll deriving Show+data JoinType = LeftJoin deriving Show++-- 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)]+ | Product (NEL.NonEmpty PrimQuery) [HPQ.PrimExpr]+ | Aggregate [(Symbol, (Maybe HPQ.AggrOp, HPQ.PrimExpr))] PrimQuery+ | Order [HPQ.OrderExpr] PrimQuery+ | Limit LimitOp PrimQuery+ | Join JoinType [(Symbol, HPQ.PrimExpr)] HPQ.PrimExpr PrimQuery PrimQuery+ | Values [Symbol] [[HPQ.PrimExpr]]+ | Binary BinOp [(Symbol, (HPQ.PrimExpr, HPQ.PrimExpr))] (PrimQuery, PrimQuery)+ deriving Show++type PrimQueryFold p = ( p+ , String -> [(Symbol, HPQ.PrimExpr)] -> p+ , NEL.NonEmpty p -> [HPQ.PrimExpr] -> p+ , [(Symbol, (Maybe HPQ.AggrOp, HPQ.PrimExpr))] -> p -> p+ , [HPQ.OrderExpr] -> p -> p+ , LimitOp -> p -> p+ , JoinType -> [(Symbol, HPQ.PrimExpr)] -> HPQ.PrimExpr -> p -> p -> p+ , [Symbol] -> [[HPQ.PrimExpr]] -> p+ , BinOp -> [(Symbol, (HPQ.PrimExpr, HPQ.PrimExpr))] -> (p, p) -> p+ )++foldPrimQuery :: PrimQueryFold p -> PrimQuery -> p+foldPrimQuery (unit, baseTable, product, aggregate, order, limit, join, values,+ binary) = fix fold+ where fold self primQ = case primQ of+ Unit -> unit+ BaseTable n s -> baseTable n s+ Product pqs pes -> product (fmap self pqs) pes+ Aggregate aggrs pq -> aggregate aggrs (self pq)+ Order pes pq -> order pes (self pq)+ Limit op pq -> limit op (self pq)+ Join j pes cond q1 q2 -> join j pes cond (self q1) (self q2)+ Values ss pes -> values ss pes+ Binary binop pes (pq, pq') -> binary binop pes (self pq, self pq')+ fix f = let x = f x in x++times :: PrimQuery -> PrimQuery -> PrimQuery+times q q' = Product (q NEL.:| [q']) []++restrict :: HPQ.PrimExpr -> PrimQuery -> PrimQuery+restrict cond primQ = Product (return primQ) [cond]++isUnit :: PrimQuery -> Bool+isUnit Unit = True+isUnit _ = False
+ src/Opaleye/Internal/Print.hs view
@@ -0,0 +1,114 @@+module Opaleye.Internal.Print where++import Prelude hiding (product)++import qualified Opaleye.Internal.Sql as Sql+import Opaleye.Internal.Sql (Select(SelectFrom, Table,+ SelectJoin,+ SelectValues,+ SelectBinary),+ From, Join, Values, Binary)++import qualified Opaleye.Internal.HaskellDB.Sql as HSql+import qualified Opaleye.Internal.HaskellDB.Sql.Print as HPrint++import Text.PrettyPrint.HughesPJ (Doc, ($$), (<+>), text, empty,+ parens)++ppSql :: Select -> Doc+ppSql (SelectFrom s) = ppSelectFrom s+ppSql (Table name) = text name+ppSql (SelectJoin j) = ppSelectJoin j+ppSql (SelectValues v) = ppSelectValues v+ppSql (SelectBinary v) = ppSelectBinary v++ppSelectFrom :: From -> Doc+ppSelectFrom s = text "SELECT"+ <+> ppAttrs (Sql.attrs s)+ $$ ppTables (Sql.tables s)+ $$ HPrint.ppWhere (Sql.criteria s)+ $$ ppGroupBy (Sql.groupBy s)+ $$ HPrint.ppOrderBy (Sql.orderBy s)+ $$ ppLimit (Sql.limit s)+ $$ ppOffset (Sql.offset s)+++ppSelectJoin :: Join -> Doc+ppSelectJoin j = text "SELECT"+ <+> ppAttrs (Sql.jAttrs j)+ $$ text "FROM"+ $$ ppTable (tableAlias 1 s1)+ $$ ppJoinType (Sql.jJoinType j)+ $$ ppTable (tableAlias 2 s2)+ $$ text "ON"+ $$ HPrint.ppSqlExpr (Sql.jCond j)+ where (s1, s2) = Sql.jTables j++ppSelectValues :: Values -> Doc+ppSelectValues v = text "SELECT"+ <+> ppAttrs (Sql.vAttrs v)+ $$ text "FROM"+ $$ ppValues (Sql.vValues v)++ppSelectBinary :: Binary -> Doc+ppSelectBinary b = ppSql (Sql.bSelect1 b)+ $$ ppBinOp (Sql.bOp b)+ $$ ppSql (Sql.bSelect2 b)++ppJoinType :: Sql.JoinType -> Doc+ppJoinType Sql.LeftJoin = text "LEFT OUTER JOIN"++ppAttrs :: [(HSql.SqlExpr, Maybe HSql.SqlColumn)] -> Doc+ppAttrs [] = text "*"+ppAttrs xs = HPrint.commaV nameAs xs++-- This is pretty much just nameAs from HaskellDB+nameAs :: (HSql.SqlExpr, Maybe HSql.SqlColumn) -> Doc+nameAs (expr, name) = HPrint.ppAs (maybe "" unColumn name) (HPrint.ppSqlExpr expr)+ where unColumn (HSql.SqlColumn s) = s++ppTables :: [Select] -> Doc+ppTables [] = empty+ppTables ts = text "FROM" <+> HPrint.commaV ppTable (zipWith tableAlias [1..] ts)++tableAlias :: Int -> Select -> (HSql.SqlTable, Select)+tableAlias i select = ("T" ++ show i, select)++-- TODO: duplication with ppSql+ppTable :: (HSql.SqlTable, Select) -> Doc+ppTable (alias, select) = case select of+ Table name -> HPrint.ppAs alias (text name)+ SelectFrom selectFrom -> HPrint.ppAs alias (parens (ppSelectFrom selectFrom))+ SelectJoin slj -> HPrint.ppAs alias (parens (ppSelectJoin slj))+ SelectValues slv -> HPrint.ppAs alias (parens (ppSelectValues slv))+ SelectBinary slb -> HPrint.ppAs alias (parens (ppSelectBinary slb))++ppGroupBy :: [HSql.SqlExpr] -> Doc+ppGroupBy [] = empty+ppGroupBy xs = HPrint.ppGroupBy xs++ppLimit :: Maybe Int -> Doc+ppLimit Nothing = empty+ppLimit (Just n) = text ("LIMIT " ++ show n)++ppOffset :: Maybe Int -> Doc+ppOffset Nothing = empty+ppOffset (Just n) = text ("OFFSET " ++ show n)++ppValues :: [[HSql.SqlExpr]] -> Doc+ppValues v = HPrint.ppAs "V" (parens (text "VALUES" $$ HPrint.commaV ppValuesRow v))++ppValuesRow :: [HSql.SqlExpr] -> Doc+ppValuesRow = parens . HPrint.commaH HPrint.ppSqlExpr++ppBinOp :: Sql.BinOp -> Doc+ppBinOp o = text $ case o of+ Sql.Union -> "UNION"+ Sql.UnionAll -> "UNION ALL"+ Sql.Except -> "EXCEPT"++ppInsertReturning :: Sql.Returning HSql.SqlInsert -> Doc+ppInsertReturning (Sql.Returning insert returnExprs) =+ HPrint.ppInsert insert+ $$ text "RETURNING"+ <+> HPrint.commaV HPrint.ppSqlExpr returnExprs
+ src/Opaleye/Internal/QueryArr.hs view
@@ -0,0 +1,67 @@+module Opaleye.Internal.QueryArr where++import Prelude hiding (id)++import qualified Opaleye.Internal.Unpackspec as U+import qualified Opaleye.Internal.Tag as Tag+import Opaleye.Internal.Tag (Tag)+import qualified Opaleye.Internal.PrimQuery as PQ++import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ++import qualified Control.Arrow as Arr+import Control.Arrow ((&&&), (***), arr)+import qualified Control.Category as C+import Control.Category ((<<<), id)+import Control.Applicative (Applicative, pure, (<*>))+import qualified Data.Profunctor as P+import qualified Data.Profunctor.Product as PP++newtype QueryArr a b = QueryArr ((a, PQ.PrimQuery, Tag) -> (b, PQ.PrimQuery, Tag))+type Query = QueryArr ()++simpleQueryArr :: ((a, Tag) -> (b, PQ.PrimQuery, Tag)) -> QueryArr a b+simpleQueryArr f = QueryArr g+ where g (a0, primQuery, t0) = (a1, PQ.times primQuery primQuery', t1)+ where (a1, primQuery', t1) = f (a0, t0)++runQueryArr :: QueryArr a b -> (a, PQ.PrimQuery, Tag) -> (b, PQ.PrimQuery, Tag)+runQueryArr (QueryArr f) = f++runSimpleQueryArr :: QueryArr a b -> (a, Tag) -> (b, PQ.PrimQuery, Tag)+runSimpleQueryArr f (a, t) = runQueryArr f (a, PQ.Unit, t)++runQueryArrUnpack :: U.Unpackspec a b+ -> Query a -> ([HPQ.PrimExpr], PQ.PrimQuery, Tag)+runQueryArrUnpack unpackspec q = (primExprs, primQ, endTag)+ where (columns, primQ, endTag) = runSimpleQueryArr q ((), Tag.start)+ f pe = ([pe], pe)+ primExprs :: [HPQ.PrimExpr]+ (primExprs, _) = U.runUnpackspec unpackspec f columns++first3 :: (a1 -> b) -> (a1, a2, a3) -> (b, a2, a3)+first3 f (a1, a2, a3) = (f a1, a2, a3)++instance C.Category QueryArr where+ id = QueryArr id+ QueryArr f . QueryArr g = QueryArr (f . g)++instance Arr.Arrow QueryArr where+ arr f = QueryArr (first3 f)+ first f = QueryArr g+ where g ((b, d), primQ, t0) = ((c, d), primQ', t1)+ where (c, primQ', t1) = runQueryArr f (b, primQ, t0)++instance Functor (QueryArr a) where+ fmap f = (arr f <<<)++instance Applicative (QueryArr a) where+ pure = arr . const+ f <*> g = arr (uncurry ($)) <<< (f &&& g)++instance P.Profunctor QueryArr where+ dimap f g a = arr g <<< a <<< arr f++instance PP.ProductProfunctor QueryArr where+ empty = id+ (***!) = (***)
+ src/Opaleye/Internal/RunQuery.hs view
@@ -0,0 +1,127 @@+{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-}++module Opaleye.Internal.RunQuery where++import Control.Applicative (Applicative, pure, (<*>))++import Database.PostgreSQL.Simple.Internal (RowParser)+import Database.PostgreSQL.Simple.FromField (FieldParser, FromField,+ fromField)+import Database.PostgreSQL.Simple.FromRow (fieldWith)++import Opaleye.Column (Column)+import Opaleye.Internal.Column (Nullable)+import qualified Opaleye.Column as C+import qualified Opaleye.Internal.Unpackspec as U+import Opaleye.PGTypes as T++import qualified Data.Profunctor as P+import Data.Profunctor (dimap)+import qualified Data.Profunctor.Product as PP+import Data.Profunctor.Product (empty, (***!))+import qualified Data.Profunctor.Product.Default as D++import qualified Data.Text as ST+import qualified Data.Text.Lazy as LT+import qualified Data.Time as Time+import Data.UUID (UUID)+import GHC.Int (Int64)++data QueryRunnerColumn coltype haskell =+ QueryRunnerColumn (U.Unpackspec (Column coltype) ()) (FieldParser haskell)++data QueryRunner columns haskells = QueryRunner (U.Unpackspec columns ())+ (RowParser haskells)++fieldQueryRunnerColumn :: FromField haskell => QueryRunnerColumn coltype haskell+fieldQueryRunnerColumn =+ QueryRunnerColumn (P.rmap (const ()) U.unpackspecColumn) fromField++queryRunner :: QueryRunnerColumn a b -> QueryRunner (Column a) b+queryRunner qrc = QueryRunner u (fieldWith fp)+ where QueryRunnerColumn u fp = qrc++queryRunnerColumnNullable :: QueryRunnerColumn a b+ -> QueryRunnerColumn (Nullable a) (Maybe b)+queryRunnerColumnNullable qr =+ QueryRunnerColumn (P.lmap C.unsafeCoerce u) (fromField' fp)+ where QueryRunnerColumn u fp = qr+ fromField' :: FieldParser a -> FieldParser (Maybe a)+ fromField' _ _ Nothing = pure Nothing+ fromField' fp' f bs = fmap Just (fp' f bs)++-- { Instances for automatic derivation++instance QueryRunnerColumnDefault a b =>+ QueryRunnerColumnDefault (Nullable a) (Maybe b) where+ queryRunnerColumnDefault = queryRunnerColumnNullable queryRunnerColumnDefault++instance QueryRunnerColumnDefault a b =>+ D.Default QueryRunner (Column a) b where+ def = queryRunner queryRunnerColumnDefault++-- }++-- { Instances that must be provided once for each type. Instances+-- for Nullable are derived automatically from these.++class QueryRunnerColumnDefault a b where+ queryRunnerColumnDefault :: QueryRunnerColumn a b++instance QueryRunnerColumnDefault T.PGInt4 Int where+ queryRunnerColumnDefault = fieldQueryRunnerColumn++instance QueryRunnerColumnDefault T.PGInt8 Int64 where+ queryRunnerColumnDefault = fieldQueryRunnerColumn++instance QueryRunnerColumnDefault T.PGText String where+ queryRunnerColumnDefault = fieldQueryRunnerColumn++instance QueryRunnerColumnDefault T.PGFloat8 Double where+ queryRunnerColumnDefault = fieldQueryRunnerColumn++instance QueryRunnerColumnDefault T.PGBool Bool where+ queryRunnerColumnDefault = fieldQueryRunnerColumn++instance QueryRunnerColumnDefault T.PGUuid UUID where+ queryRunnerColumnDefault = fieldQueryRunnerColumn++instance QueryRunnerColumnDefault T.PGText ST.Text where+ queryRunnerColumnDefault = fieldQueryRunnerColumn++instance QueryRunnerColumnDefault T.PGText LT.Text where+ queryRunnerColumnDefault = fieldQueryRunnerColumn++instance QueryRunnerColumnDefault T.PGDate Time.Day where+ queryRunnerColumnDefault = fieldQueryRunnerColumn++instance QueryRunnerColumnDefault T.PGTimestamptz Time.UTCTime where+ queryRunnerColumnDefault = fieldQueryRunnerColumn++instance QueryRunnerColumnDefault T.PGTimestamp Time.LocalTime where+ queryRunnerColumnDefault = fieldQueryRunnerColumn++instance QueryRunnerColumnDefault T.PGTime Time.TimeOfDay where+ queryRunnerColumnDefault = fieldQueryRunnerColumn++-- }++-- Boilerplate instances++instance Functor (QueryRunner c) where+ fmap f (QueryRunner u r) = QueryRunner u (fmap f r)++-- TODO: Seems like this one should be simpler!+instance Applicative (QueryRunner c) where+ pure = QueryRunner (P.lmap (const ()) PP.empty) . pure+ QueryRunner uf rf <*> QueryRunner ux rx =+ QueryRunner (P.dimap (\x -> (x,x)) (const ()) (uf PP.***! ux)) (rf <*> rx)++instance P.Profunctor QueryRunner where+ dimap f g (QueryRunner u r) = QueryRunner (P.lmap f u) (fmap g r)++instance PP.ProductProfunctor QueryRunner where+ empty = PP.defaultEmpty+ (***!) = PP.defaultProfunctorProduct++-- }
+ src/Opaleye/Internal/Sql.hs view
@@ -0,0 +1,169 @@+module Opaleye.Internal.Sql where++import Prelude hiding (product)++import qualified Opaleye.Internal.PrimQuery as PQ++import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ+import Opaleye.Internal.HaskellDB.PrimQuery (Symbol(Symbol))+import qualified Opaleye.Internal.HaskellDB.Sql as HSql+import qualified Opaleye.Internal.HaskellDB.Sql.Default as SD+import qualified Opaleye.Internal.HaskellDB.Sql.Generate as SG+import qualified Opaleye.Internal.Tag as T++import qualified Data.List.NonEmpty as NEL+import qualified Data.Maybe as M++import qualified Control.Arrow as Arr++data Select = SelectFrom From+ | Table HSql.SqlTable+ | SelectJoin Join+ | SelectValues Values+ | SelectBinary Binary+ deriving Show++data From = From {+ attrs :: [(HSql.SqlExpr, Maybe HSql.SqlColumn)],+ tables :: [Select],+ criteria :: [HSql.SqlExpr],+ groupBy :: [HSql.SqlExpr],+ orderBy :: [(HSql.SqlExpr, HSql.SqlOrder)],+ limit :: Maybe Int,+ offset :: Maybe Int+ }+ deriving Show++data Join = Join {+ jJoinType :: JoinType,+ jAttrs :: [(HSql.SqlExpr, Maybe HSql.SqlColumn)],+ jTables :: (Select, Select),+ jCond :: HSql.SqlExpr+ }+ deriving Show++data Values = Values {+ vAttrs :: [(HSql.SqlExpr, Maybe HSql.SqlColumn)],+ vValues :: [[HSql.SqlExpr]]+} deriving Show++data Binary = Binary {+ bOp :: BinOp,+ bSelect1 :: Select,+ bSelect2 :: Select+} deriving Show++data JoinType = LeftJoin deriving Show+data BinOp = Except | Union | UnionAll deriving Show++data TableName = String++data Returning a = Returning a [HSql.SqlExpr]++sqlQueryGenerator :: PQ.PrimQueryFold Select+sqlQueryGenerator = (unit, baseTable, product, aggregate, order, limit_, join,+ values, binary)++sql :: ([HPQ.PrimExpr], PQ.PrimQuery, T.Tag) -> Select+sql (pes, pq, t) = SelectFrom $ newSelect { attrs = makeAttrs pes+ , tables = [pqSelect] }+ where pqSelect = PQ.foldPrimQuery sqlQueryGenerator pq+ makeAttrs = flip (zipWith makeAttr) [1..]+ makeAttr pe i = sqlBinding (Symbol ("result" ++ show (i :: Int)) t, pe)++unit :: Select+unit = SelectFrom newSelect { attrs = [(HSql.ConstSqlExpr "0", Nothing)] }++baseTable :: String -> [(Symbol, HPQ.PrimExpr)] -> Select+baseTable name columns = SelectFrom $+ newSelect { attrs = map sqlBinding columns+ , tables = [Table name] }++product :: NEL.NonEmpty Select -> [HPQ.PrimExpr] -> Select+product ss pes = SelectFrom $+ newSelect { tables = NEL.toList ss+ , criteria = map sqlExpr pes }++aggregate :: [(Symbol, (Maybe HPQ.AggrOp, HPQ.PrimExpr))] -> Select -> Select+aggregate aggrs s = SelectFrom $ newSelect { attrs = map attr aggrs+ , tables = [s]+ , groupBy = groupBy' }+ where groupBy' = (map sqlExpr+ . map expr+ . filter (M.isNothing . aggrOp)) aggrs+ attr = sqlBinding . Arr.second (uncurry aggrExpr)+ expr (_, (_, e)) = e+ aggrOp (_, (x, _)) = x+++aggrExpr :: Maybe HPQ.AggrOp -> HPQ.PrimExpr -> HPQ.PrimExpr+aggrExpr = maybe id HPQ.AggrExpr++order :: [HPQ.OrderExpr] -> Select -> Select+order oes s = SelectFrom $+ newSelect { tables = [s]+ , orderBy = map (SD.toSqlOrder SD.defaultSqlGenerator) oes }++limit_ :: PQ.LimitOp -> Select -> Select+limit_ lo s = SelectFrom $ newSelect { tables = [s]+ , limit = limit'+ , offset = offset' }+ where (limit', offset') = case lo of+ PQ.LimitOp n -> (Just n, Nothing)+ PQ.OffsetOp n -> (Nothing, Just n)+ PQ.LimitOffsetOp l o -> (Just l, Just o)++join :: PQ.JoinType -> [(Symbol, HPQ.PrimExpr)] -> HPQ.PrimExpr -> Select -> Select+ -> Select+join j columns cond s1 s2 = SelectJoin Join { jJoinType = joinType j+ , jAttrs = mkAttrs columns+ , jTables = (s1, s2)+ , jCond = sqlExpr cond }+ where mkAttrs = map sqlBinding++-- Postgres seems to name columns of VALUES clauses "column1",+-- "column2", ... . I'm not sure to what extent it is customisable or+-- how robust it is to rely on this+values :: [Symbol] -> [[HPQ.PrimExpr]] -> Select+values columns pes = SelectValues Values { vAttrs = mkColumns columns+ , vValues = (map . map) sqlExpr pes }+ where mkColumns = zipWith (flip (curry (sqlBinding . Arr.second mkColumn))) [1..]+ mkColumn i = (HPQ.BaseTableAttrExpr . ("column" ++) . show) (i::Int)++binary :: PQ.BinOp -> [(Symbol, (HPQ.PrimExpr, HPQ.PrimExpr))]+ -> (Select, Select) -> Select+binary op pes (select1, select2) = SelectBinary Binary {+ bOp = binOp op,+ bSelect1 = SelectFrom newSelect { attrs = map (mkColumn fst) pes,+ tables = [select1] },+ bSelect2 = SelectFrom newSelect { attrs = map (mkColumn snd) pes,+ tables = [select2] }+ }+ where mkColumn e = sqlBinding . Arr.second e++joinType :: PQ.JoinType -> JoinType+joinType PQ.LeftJoin = LeftJoin++binOp :: PQ.BinOp -> BinOp+binOp o = case o of+ PQ.Except -> Except+ PQ.Union -> Union+ PQ.UnionAll -> UnionAll++newSelect :: From+newSelect = From {+ attrs = [],+ tables = [],+ criteria = [],+ groupBy = [],+ orderBy = [],+ limit = Nothing,+ offset = Nothing+ }++sqlExpr :: HPQ.PrimExpr -> HSql.SqlExpr+sqlExpr = SG.sqlExpr SD.defaultSqlGenerator++sqlBinding :: (Symbol, HPQ.PrimExpr) -> (HSql.SqlExpr, Maybe HSql.SqlColumn)+sqlBinding (Symbol sym t, pe) =+ (sqlExpr pe, Just (HSql.SqlColumn (T.tagWith t sym)))
+ src/Opaleye/Internal/Table.hs view
@@ -0,0 +1,135 @@+{-# LANGUAGE FlexibleContexts #-}++module Opaleye.Internal.Table where++import Opaleye.Internal.Column (Column(Column))+import qualified Opaleye.Internal.TableMaker as TM+import qualified Opaleye.Internal.Tag as Tag+import qualified Opaleye.Internal.PrimQuery as PQ+import qualified Opaleye.Internal.PackMap as PM++import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ++import Data.Profunctor (Profunctor, dimap, lmap)+import Data.Profunctor.Product (ProductProfunctor, empty, (***!))+import qualified Data.Profunctor.Product as PP+import Control.Applicative (Applicative, pure, (<*>), liftA2)++-- | Define a table as follows, where \"id\", \"color\", \"location\",+-- \"quantity\" and \"radius\" are the tables columns in Postgres and+-- the types are given in the type signature. The @id@ field is an+-- autoincrementing field (i.e. optional for writes).+--+-- @+-- data Widget a b c d e = Widget { wid :: a+-- , color :: b+-- , location :: c+-- , quantity :: d+-- , radius :: e }+--+-- $('Data.Profunctor.Product.TH.makeAdaptorAndInstance' \"pWidget\" ''Widget)+--+-- widgetTable :: Table (Widget (Maybe (Column PGInt4)) (Column PGText) (Column PGText)+-- (Column PGInt4) (Column PGFloat8))+-- (Widget (Column PGText) (Column PGText) (Column PGText)+-- (Column PGInt4) (Column PGFloat8))+-- widgetTable = Table \"widgetTable\"+-- (pWidget Widget { wid = optional \"id\"+-- , color = required \"color\"+-- , location = required \"location\"+-- , quantity = required \"quantity\"+-- , radius = required \"radius\" })+-- @+data Table writerColumns viewColumns =+ Table String (TableProperties writerColumns viewColumns)++data TableProperties writerColumns viewColumns =+ TableProperties (Writer writerColumns viewColumns) (View viewColumns)++data View columns = View columns++-- If we switch to a more lens-like approach to PackMap this should be+-- the equivalent of a Fold++-- There's no reason the second parameter should exist except that we+-- use ProductProfunctors more than ProductContravariants so it makes+-- things easier if we make it one of the former.+data Writer columns dummy =+ Writer (PM.PackMap (HPQ.PrimExpr, String) () columns ())++queryTable :: TM.ColumnMaker viewColumns columns+ -> Table writerColumns viewColumns+ -> Tag.Tag+ -> (columns, PQ.PrimQuery)+queryTable cm table tag = (primExprs, primQ) where+ (Table tableName (TableProperties _ (View tableCols))) = table+ (primExprs, projcols) = runColumnMaker cm tag tableCols+ primQ :: PQ.PrimQuery+ primQ = PQ.BaseTable tableName projcols++runColumnMaker :: TM.ColumnMaker tablecolumns columns+ -> Tag.Tag+ -> tablecolumns+ -> (columns, [(HPQ.Symbol, HPQ.PrimExpr)])+runColumnMaker cm tag tableCols = PM.run (TM.runColumnMaker cm f tableCols) where+ f = PM.extractAttrPE mkName tag+ -- The non-AttrExpr PrimExprs are not created by 'makeView' or a+ -- 'ViewColumnMaker' so could only arise from an fmap (if we+ -- implemented a Functor instance) or a direct manipulation of the+ -- tablecols contained in the View (which would be naughty)+ mkName pe i = (++ i) $ case pe of+ HPQ.BaseTableAttrExpr columnName -> columnName+ _ -> "tablecolumn"++runWriter :: Writer columns columns' -> columns -> [(HPQ.PrimExpr, String)]+runWriter (Writer (PM.PackMap f)) columns = outColumns+ where extractColumns t = ([t], ())+ (outColumns, ()) = f extractColumns columns++required :: String -> Writer (Column a) (Column a)+required columnName =+ Writer (PM.PackMap (\f (Column primExpr) -> f (primExpr, columnName)))++optional :: String -> Writer (Maybe (Column a)) (Column a)+optional columnName =+ Writer (PM.PackMap (\f c -> case c of+ Nothing -> pure ()+ Just (Column primExpr) -> f (primExpr, columnName)))++-- {++-- Boilerplate instance definitions++instance Functor (Writer a) where+ fmap _ (Writer g) = Writer g++instance Applicative (Writer a) where+ pure x = Writer (fmap (const ()) (pure x))+ Writer f <*> Writer x = Writer (liftA2 (\_ _ -> ()) f x)++instance Profunctor Writer where+ dimap f _ (Writer h) = Writer (lmap f h)++instance ProductProfunctor Writer where+ empty = PP.defaultEmpty+ (***!) = PP.defaultProfunctorProduct++instance Functor (TableProperties a) where+ fmap f (TableProperties w (View v)) = TableProperties (fmap f w) (View (f v))++instance Applicative (TableProperties a) where+ pure x = TableProperties (pure x) (View x)+ TableProperties fw (View fv) <*> TableProperties xw (View xv) =+ TableProperties (fw <*> xw) (View (fv xv))++instance Profunctor TableProperties where+ dimap f g (TableProperties w (View v)) = TableProperties (dimap f g w)+ (View (g v))+instance ProductProfunctor TableProperties where+ empty = PP.defaultEmpty+ (***!) = PP.defaultProfunctorProduct++instance Functor (Table a) where+ fmap f (Table s tp) = Table s (fmap f tp)++-- }
+ src/Opaleye/Internal/TableMaker.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}++module Opaleye.Internal.TableMaker where++import qualified Opaleye.Column as C+import qualified Opaleye.Internal.Column as IC+import qualified Opaleye.Internal.PackMap as PM++import Data.Profunctor (Profunctor, dimap)+import Data.Profunctor.Product (ProductProfunctor, empty, (***!))+import qualified Data.Profunctor.Product as PP+import Data.Profunctor.Product.Default (Default, def)++import Control.Applicative (Applicative, pure, (<*>))++import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ+++-- If we switch to a more lens-like approach to PackMap this should be+-- the equivalent of a Setter+newtype ViewColumnMaker strings columns =+ ViewColumnMaker (PM.PackMap () () strings columns)++newtype ColumnMaker columns columns' =+ ColumnMaker (PM.PackMap HPQ.PrimExpr HPQ.PrimExpr columns columns')++runViewColumnMaker :: ViewColumnMaker strings tablecolumns ->+ strings -> tablecolumns+runViewColumnMaker (ViewColumnMaker f) = PM.over f id++runColumnMaker :: Applicative f+ => ColumnMaker tablecolumns columns+ -> (HPQ.PrimExpr -> f HPQ.PrimExpr)+ -> tablecolumns -> f columns+runColumnMaker (ColumnMaker f) = PM.packmap f++-- There's surely a way of simplifying this implementation+tableColumn :: ViewColumnMaker String (C.Column a)+tableColumn = ViewColumnMaker+ (PM.PackMap (\f s -> fmap (const (mkColumn s)) (f ())))+ where mkColumn = IC.Column . HPQ.BaseTableAttrExpr++column :: ColumnMaker (C.Column a) (C.Column a)+column = ColumnMaker+ (PM.PackMap (\f (IC.Column s)+ -> fmap IC.Column (f s)))++instance Default ViewColumnMaker String (C.Column a) where+ def = tableColumn++instance Default ColumnMaker (C.Column a) (C.Column a) where+ def = column++-- {++-- Boilerplate instance definitions. Theoretically, these are derivable.++instance Functor (ViewColumnMaker a) where+ fmap f (ViewColumnMaker g) = ViewColumnMaker (fmap f g)++instance Applicative (ViewColumnMaker a) where+ pure = ViewColumnMaker . pure+ ViewColumnMaker f <*> ViewColumnMaker x = ViewColumnMaker (f <*> x)++instance Profunctor ViewColumnMaker where+ dimap f g (ViewColumnMaker q) = ViewColumnMaker (dimap f g q)++instance ProductProfunctor ViewColumnMaker where+ empty = PP.defaultEmpty+ (***!) = PP.defaultProfunctorProduct++instance Functor (ColumnMaker a) where+ fmap f (ColumnMaker g) = ColumnMaker (fmap f g)++instance Applicative (ColumnMaker a) where+ pure = ColumnMaker . pure+ ColumnMaker f <*> ColumnMaker x = ColumnMaker (f <*> x)++instance Profunctor ColumnMaker where+ dimap f g (ColumnMaker q) = ColumnMaker (dimap f g q)++instance ProductProfunctor ColumnMaker where+ empty = PP.defaultEmpty+ (***!) = PP.defaultProfunctorProduct++--}
+ src/Opaleye/Internal/Tag.hs view
@@ -0,0 +1,15 @@+module Opaleye.Internal.Tag where++data Tag = UnsafeTag Int deriving (Read, Show)++start :: Tag+start = UnsafeTag 1++next :: Tag -> Tag+next = UnsafeTag . (+1) . unsafeUnTag++unsafeUnTag :: Tag -> Int+unsafeUnTag (UnsafeTag i) = i++tagWith :: Tag -> String -> String+tagWith t s = s ++ "_" ++ show (unsafeUnTag t)
+ src/Opaleye/Internal/Unpackspec.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}++module Opaleye.Internal.Unpackspec where++import qualified Opaleye.Internal.PackMap as PM+import qualified Opaleye.Internal.Column as IC+import qualified Opaleye.Column as C++import Control.Applicative (Applicative, pure, (<*>))+import Data.Profunctor (Profunctor, dimap)+import Data.Profunctor.Product (ProductProfunctor, empty, (***!))+import qualified Data.Profunctor.Product as PP+import qualified Data.Profunctor.Product.Default as D++import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ++newtype Unpackspec columns columns' =+ Unpackspec (PM.PackMap HPQ.PrimExpr HPQ.PrimExpr columns columns')++unpackspecColumn :: Unpackspec (C.Column a) (C.Column a)+unpackspecColumn = Unpackspec+ (PM.PackMap (\f (IC.Column pe) -> fmap IC.Column (f pe)))++runUnpackspec :: Applicative f+ => Unpackspec columns b+ -> (HPQ.PrimExpr -> f HPQ.PrimExpr)+ -> columns -> f b+runUnpackspec (Unpackspec f) = PM.packmap f++instance D.Default Unpackspec (C.Column a) (C.Column a) where+ def = unpackspecColumn++-- {++-- Boilerplate instance definitions. Theoretically, these are derivable.++instance Functor (Unpackspec a) where+ fmap f (Unpackspec g) = Unpackspec (fmap f g)++instance Applicative (Unpackspec a) where+ pure = Unpackspec . pure+ Unpackspec f <*> Unpackspec x = Unpackspec (f <*> x)++instance Profunctor Unpackspec where+ dimap f g (Unpackspec q) = Unpackspec (dimap f g q)++instance ProductProfunctor Unpackspec where+ empty = PP.defaultEmpty+ (***!) = PP.defaultProfunctorProduct++--}
+ src/Opaleye/Internal/Values.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}++module Opaleye.Internal.Values where++import qualified Opaleye.PGTypes as T++import Opaleye.Internal.Column (Column(Column))+import qualified Opaleye.Internal.Unpackspec as U+import qualified Opaleye.Internal.Tag as T+import qualified Opaleye.Internal.PrimQuery as PQ+import qualified Opaleye.Internal.PackMap as PM+import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ++import Data.Profunctor (Profunctor, dimap, rmap)+import Data.Profunctor.Product (ProductProfunctor, empty, (***!))+import qualified Data.Profunctor.Product as PP+import Data.Profunctor.Product.Default (Default, def)++import Control.Applicative (Applicative, pure, (<*>))++-- There are two annoyances with creating SQL VALUES statements+--+-- 1. SQL does not allow empty VALUES statements so if we want to+-- create a VALUES statement from an empty list we have to fake it+-- somehow. The current approach is to make a VALUES statement+-- with a single row of NULLs and then restrict it with WHERE+-- FALSE.++-- 2. Postgres's type inference of constants is pretty poor so we will+-- sometimes have to give explicit type signatures. The future+-- ShowConstant class will have the same problem. NB We don't+-- actually currently address this problem.++valuesU :: U.Unpackspec columns columns'+ -> Valuesspec columns columns'+ -> [columns]+ -> ((), T.Tag) -> (columns', PQ.PrimQuery, T.Tag)+valuesU unpack valuesspec rows ((), t) = (newColumns, primQ', T.next t)+ where runRow row = valuesRow+ where (_, valuesRow) =+ PM.run (U.runUnpackspec unpack extractValuesEntry row)++ (newColumns, valuesPEs_nulls) =+ PM.run (runValuesspec valuesspec (extractValuesField t))++ valuesPEs = map fst valuesPEs_nulls+ nulls = map snd valuesPEs_nulls++ yieldNoRows :: PQ.PrimQuery -> PQ.PrimQuery+ yieldNoRows = PQ.restrict (HPQ.ConstExpr (HPQ.BoolLit False))++ values' :: [[HPQ.PrimExpr]]+ (values', wrap) = if null rows+ then ([nulls], yieldNoRows)+ else (map runRow rows, id)++ primQ' = wrap (PQ.Values valuesPEs values')++-- We don't actually use the return value of this. It might be better+-- to come up with another Applicative instance for specifically doing+-- what we need.+extractValuesEntry :: HPQ.PrimExpr -> PM.PM [HPQ.PrimExpr] HPQ.PrimExpr+extractValuesEntry pe = do+ PM.write pe+ return pe++extractValuesField :: T.Tag -> HPQ.PrimExpr+ -> PM.PM [(HPQ.Symbol, HPQ.PrimExpr)] HPQ.PrimExpr+extractValuesField = PM.extractAttr "values"++data Valuesspec columns columns' =+ Valuesspec (PM.PackMap HPQ.PrimExpr HPQ.PrimExpr () columns')++runValuesspec :: Applicative f => Valuesspec columns columns'+ -> (HPQ.PrimExpr -> f HPQ.PrimExpr) -> f columns'+runValuesspec (Valuesspec v) f = PM.packmap v f ()++instance Default Valuesspec (Column T.PGInt4) (Column T.PGInt4) where+ def = Valuesspec (PM.PackMap (\f () -> fmap Column (f (HPQ.ConstExpr HPQ.NullLit))))++-- {++-- Boilerplate instance definitions. Theoretically, these are derivable.++instance Functor (Valuesspec a) where+ fmap f (Valuesspec g) = Valuesspec (fmap f g)++instance Applicative (Valuesspec a) where+ pure = Valuesspec . pure+ Valuesspec f <*> Valuesspec x = Valuesspec (f <*> x)++instance Profunctor Valuesspec where+ dimap _ g (Valuesspec q) = Valuesspec (rmap g q)++instance ProductProfunctor Valuesspec where+ empty = PP.defaultEmpty+ (***!) = PP.defaultProfunctorProduct++-- }
+ src/Opaleye/Join.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-}++module Opaleye.Join where++import qualified Opaleye.Internal.Unpackspec as U+import qualified Opaleye.Internal.Join as J+import qualified Opaleye.Internal.Tag as T+import qualified Opaleye.Internal.PrimQuery as PQ+import qualified Opaleye.Internal.PackMap as PM+import Opaleye.QueryArr (Query)+import qualified Opaleye.Internal.QueryArr as Q+import Opaleye.Internal.Column (Column(Column))+import qualified Opaleye.PGTypes as T++import qualified Data.Profunctor.Product.Default as D++-- | Example specialization:+--+-- @+-- leftJoin :: Query (Column a, Column b)+-- -> Query (Column c, Column (Nullable d))+-- -> (((Column a, Column b), (Column c, Column (Nullable d))) -> Column 'Opaleye.PGTypes.PGBool')+-- -> Query ((Column a, Column b), (Column (Nullable c), Column (Nullable d)))+-- @+leftJoin :: (D.Default U.Unpackspec columnsA columnsA,+ D.Default U.Unpackspec columnsB columnsB,+ D.Default J.NullMaker columnsB nullableColumnsB) =>+ Query columnsA -> Query columnsB+ -> ((columnsA, columnsB) -> Column T.PGBool)+ -> Query (columnsA, nullableColumnsB)+leftJoin = leftJoinExplicit D.def D.def D.def++leftJoinExplicit :: U.Unpackspec columnsA columnsA+ -> U.Unpackspec columnsB columnsB+ -> J.NullMaker columnsB nullableColumnsB+ -> Query columnsA -> Query columnsB+ -> ((columnsA, columnsB) -> Column T.PGBool)+ -> Query (columnsA, nullableColumnsB)+leftJoinExplicit unpackA unpackB nullmaker qA qB cond = Q.simpleQueryArr q where+ q ((), startTag) = ((newColumnsA, nullableColumnsB), primQueryR, T.next endTag)+ where (columnsA, primQueryA, midTag) = Q.runSimpleQueryArr qA ((), startTag)+ (columnsB, primQueryB, endTag) = Q.runSimpleQueryArr qB ((), midTag)++ (newColumnsA, ljPEsA) =+ PM.run (U.runUnpackspec unpackA (J.extractLeftJoinFields 1 endTag) columnsA)+ (newColumnsB, ljPEsB) =+ PM.run (U.runUnpackspec unpackB (J.extractLeftJoinFields 2 endTag) columnsB)++ nullableColumnsB = J.toNullable nullmaker newColumnsB++ Column cond' = cond (columnsA, columnsB)+ primQueryR = PQ.Join PQ.LeftJoin (ljPEsA ++ ljPEsB) cond' primQueryA primQueryB
+ src/Opaleye/Manipulation.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE FlexibleContexts #-}++module Opaleye.Manipulation (module Opaleye.Manipulation,+ U.Unpackspec) where++import qualified Opaleye.Internal.Sql as Sql+import qualified Opaleye.Internal.Print as Print+import qualified Opaleye.RunQuery as RQ+import qualified Opaleye.Internal.RunQuery as IRQ+import qualified Opaleye.Table as T+import qualified Opaleye.Internal.Table as TI+import Opaleye.Internal.Column (Column(Column))+import Opaleye.Internal.Helpers ((.:), (.:.), (.::))+import qualified Opaleye.Internal.Unpackspec as U+import Opaleye.PGTypes (PGBool)++import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ+import qualified Opaleye.Internal.HaskellDB.Sql as HSql+import qualified Opaleye.Internal.HaskellDB.Sql.Print as HPrint+import qualified Opaleye.Internal.HaskellDB.Sql.Default as SD+import qualified Opaleye.Internal.HaskellDB.Sql.Generate as SG++import qualified Database.PostgreSQL.Simple as PGS++import qualified Data.Profunctor.Product.Default as D++import Data.Int (Int64)+import Data.String (fromString)++arrangeInsert :: T.Table columns a -> columns -> HSql.SqlInsert+arrangeInsert (T.Table tableName (TI.TableProperties writer _)) columns = insert+ where outColumns' = (map (\(x, y) -> (y, x))+ . TI.runWriter writer) columns+ insert = SG.sqlInsert SD.defaultSqlGenerator tableName outColumns'++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++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+ Column condExpr = cond tableCols++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++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]+ where Column condExpr = cond tableCols++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++arrangeInsertReturning :: U.Unpackspec returned returned+ -> T.Table columnsW columnsR+ -> columnsW+ -> (columnsR -> returned)+ -> Sql.Returning HSql.SqlInsert+arrangeInsertReturning unpackspec table columns returningf =+ Sql.Returning insert returningSEs+ where insert = arrangeInsert table columns+ TI.Table _ (TI.TableProperties _ (TI.View columnsR)) = table+ returning = returningf columnsR+ -- TODO: duplication with runQueryArrUnpack+ f pe = ([pe], pe)+ returningPEs :: [HPQ.PrimExpr]+ (returningPEs, _) = U.runUnpackspec unpackspec f returning+ returningSEs = map Sql.sqlExpr returningPEs++arrangeInsertReturningSql :: U.Unpackspec returned returned+ -> T.Table columnsW columnsR+ -> columnsW+ -> (columnsR -> returned)+ -> String+arrangeInsertReturningSql = show+ . Print.ppInsertReturning+ .:: arrangeInsertReturning++runInsertReturningExplicit :: RQ.QueryRunner returned haskells+ -> U.Unpackspec returned returned+ -> PGS.Connection+ -> T.Table columnsW columnsR+ -> columnsW+ -> (columnsR -> returned)+ -> IO [haskells]+runInsertReturningExplicit qr u conn = PGS.queryWith_ rowParser conn+ . fromString+ .:. arrangeInsertReturningSql u+ where IRQ.QueryRunner _ rowParser = qr++runInsertReturning :: (D.Default RQ.QueryRunner returned haskells,+ D.Default U.Unpackspec returned returned)+ => PGS.Connection+ -> T.Table columnsW columnsR+ -> columnsW+ -> (columnsR -> returned)+ -> IO [haskells]+runInsertReturning = runInsertReturningExplicit D.def D.def
+ src/Opaleye/Operators.hs view
@@ -0,0 +1,71 @@+module Opaleye.Operators (module Opaleye.Operators) where++import Opaleye.Internal.Column (Column(Column), unsafeCase_,+ unsafeIfThenElse, unsafeGt, unsafeEq)+import qualified Opaleye.Internal.Column as C+import Opaleye.Internal.QueryArr (QueryArr(QueryArr))+import qualified Opaleye.Internal.PrimQuery as PQ+import qualified Opaleye.PGTypes as T++import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ++{-| Restrict query results to a particular condition. Corresponds to+ the guard method of the MonadPlus class.+-}+restrict :: QueryArr (Column T.PGBool) ()+restrict = QueryArr f where+ f (Column predicate, primQ, t0) = ((), PQ.restrict predicate primQ, t0)++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++infix 4 ./=+(./=) :: Column a -> Column a -> Column T.PGBool+(./=) = C.binOp HPQ.OpNotEq++infix 4 .>+(.>) :: Column a -> Column a -> Column T.PGBool+(.>) = unsafeGt++infix 4 .<+(.<) :: Column a -> Column a -> Column T.PGBool+(.<) = C.binOp HPQ.OpLt++infix 4 .<=+(.<=) :: Column a -> Column a -> Column T.PGBool+(.<=) = C.binOp HPQ.OpLtEq++infix 4 .>=+(.>=) :: Column a -> Column a -> Column T.PGBool+(.>=) = C.binOp HPQ.OpGtEq++-- For import order reasons we can't make the return type PGBool+case_ :: [(Column T.PGBool, Column a)] -> Column a -> Column a+case_ = unsafeCase_++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++not :: Column T.PGBool -> Column T.PGBool+not = C.unOp HPQ.OpNot++(.++) :: Column T.PGText -> Column T.PGText -> Column T.PGText+(.++) = C.binOp HPQ.OpCat++lower :: Column T.PGText -> Column T.PGText+lower = C.unOp HPQ.OpLower++upper :: Column T.PGText -> Column T.PGText+upper = C.unOp HPQ.OpUpper
+ src/Opaleye/Order.hs view
@@ -0,0 +1,35 @@+module Opaleye.Order (module Opaleye.Order, O.Order) where++import qualified Opaleye.Column as C+import Opaleye.QueryArr (Query)+import qualified Opaleye.Internal.QueryArr as Q+import qualified Opaleye.Internal.Order as O++import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ++{-| Order the rows of a `Query` according to the `Order`. -}+orderBy :: O.Order a -> Query a -> Query a+orderBy os q =+ Q.simpleQueryArr (O.orderByU os . Q.runSimpleQueryArr q)++-- | Specify an ascending ordering by the given expression.+asc :: (a -> C.Column b) -> O.Order a+asc = O.order HPQ.OpAsc++-- | Specify an descending ordering by the given expression.+desc :: (a -> C.Column b) -> O.Order a+desc = O.order HPQ.OpDesc++{- |+Limit the results of the given query to the given maximum number of+items.+-}+limit :: Int -> Query a -> Query a+limit n a = Q.simpleQueryArr (O.limit' n . Q.runSimpleQueryArr a)++{- |+Offset the results of the given query by the given amount, skipping+that many result rows.+-}+offset :: Int -> Query a -> Query a+offset n a = Q.simpleQueryArr (O.offset' n . Q.runSimpleQueryArr a)
+ src/Opaleye/PGTypes.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE EmptyDataDecls #-}++module Opaleye.PGTypes where++import Opaleye.Internal.Column (Column(Column))+import qualified Opaleye.Internal.Column as C++import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ++import qualified Data.Text as SText+import qualified Data.Text.Lazy as LText+import qualified Data.Time as Time+import qualified Data.UUID as UUID+import qualified System.Locale as SL++import Data.Int (Int64)++data PGBool+data PGDate+data PGFloat4+data PGFloat8+data PGInt8+data PGInt4+data PGInt2+data PGNumeric+data PGText+data PGTime+data PGTimestamp+data PGTimestamptz+data PGUuid++instance C.PGNum PGFloat8 where+ pgFromInteger = pgDouble . fromInteger++instance C.PGNum PGInt4 where+ pgFromInteger = pgInt4 . fromInteger++instance C.PGNum PGInt8 where+ pgFromInteger = pgInt8 . fromInteger++instance C.PGFractional PGFloat8 where+ pgFromRational = pgDouble . fromRational++literalColumn :: HPQ.Literal -> Column a+literalColumn = Column . HPQ.ConstExpr++pgString :: String -> Column PGText+pgString = literalColumn . HPQ.StringLit++pgStrictText :: SText.Text -> Column PGText+pgStrictText = literalColumn . HPQ.StringLit . SText.unpack++pgLazyText :: LText.Text -> Column PGText+pgLazyText = literalColumn . HPQ.StringLit . LText.unpack++pgInt4 :: Int -> Column PGInt4+pgInt4 = literalColumn . HPQ.IntegerLit . fromIntegral++pgInt8 :: Int64 -> Column PGInt8+pgInt8 = literalColumn . HPQ.IntegerLit . fromIntegral++pgDouble :: Double -> Column PGFloat8+pgDouble = literalColumn . HPQ.DoubleLit++pgBool :: Bool -> Column PGBool+pgBool = literalColumn . HPQ.BoolLit++pgUUID :: UUID.UUID -> Column PGUuid+pgUUID = C.unsafeCoerce . pgString . UUID.toString++-- Internal use only!+unsafePgFormatTime :: Time.FormatTime t => HPQ.Name -> String -> t -> Column c+unsafePgFormatTime typeName formatString = Column+ . HPQ.CastExpr typeName+ . HPQ.ConstExpr+ . HPQ.OtherLit+ . format+ where format = Time.formatTime SL.defaultTimeLocale formatString++pgDay :: Time.Day -> Column PGDate+pgDay = unsafePgFormatTime "date" "'%F'"++pgUTCTime :: Time.UTCTime -> Column PGTimestamptz+pgUTCTime = unsafePgFormatTime "timestamptz" "'%FT%TZ'"++pgLocalTime :: Time.LocalTime -> Column PGTimestamp+pgLocalTime = unsafePgFormatTime "timestamp" "'%FT%T'"++pgTimeOfDay :: Time.TimeOfDay -> Column PGTime+pgTimeOfDay = unsafePgFormatTime "time" "'%T'"++-- "We recommend not using the type time with time zone"+-- http://www.postgresql.org/docs/8.3/static/datatype-datetime.html
+ src/Opaleye/QueryArr.hs view
@@ -0,0 +1,9 @@+{-|++This modules defines the 'QueryArr' arrow, which is an arrow that represents+selecting data from a database, and composing multiple queries together.++-}+module Opaleye.QueryArr (QueryArr, Query) where++import Opaleye.Internal.QueryArr (QueryArr, Query)
+ src/Opaleye/RunQuery.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE FlexibleContexts #-}++module Opaleye.RunQuery (module Opaleye.RunQuery,+ QueryRunner,+ IRQ.QueryRunnerColumn,+ IRQ.fieldQueryRunnerColumn) where++import qualified Database.PostgreSQL.Simple as PGS+import qualified Data.String as String++import Opaleye.Column (Column)+import qualified Opaleye.Sql as S+import Opaleye.QueryArr (Query)+import Opaleye.Internal.RunQuery (QueryRunner(QueryRunner))+import qualified Opaleye.Internal.RunQuery as IRQ++import qualified Data.Profunctor as P+import qualified Data.Profunctor.Product.Default as D++-- | Example type specialization:+--+-- @+-- runQuery :: Query (Column 'Opaleye.PGTypes.PGInt4', Column 'Opaleye.PGTypes.PGText') -> IO [(Column Int, Column String)]+-- @+--+-- Assuming the @makeAdaptorAndInstance@ splice has been run for the product type @Foo@:+--+-- @+-- runQuery :: Query (Foo (Column 'Opaleye.PGTypes.PGInt4') (Column 'Opaleye.PGTypes.PGText') (Column 'Opaleye.PGTypes.PGBool')+-- -> IO [(Foo (Column Int) (Column String) (Column Bool)]+-- @+--+-- Opaleye types are converted to Haskell types based on instances of+-- the 'Opaleye.Internal.RunQuery.QueryRunnerColumnDefault' typeclass.+runQuery :: D.Default QueryRunner columns haskells+ => PGS.Connection+ -> Query columns+ -> IO [haskells]+runQuery = runQueryExplicit D.def++runQueryExplicit :: QueryRunner columns haskells+ -> PGS.Connection+ -> Query columns+ -> IO [haskells]+runQueryExplicit (QueryRunner u rowParser) conn q =+ PGS.queryWith_ rowParser conn sql+ where sql :: PGS.Query+ sql = String.fromString (S.showSqlForPostgresExplicit u q)++-- | Use 'queryRunnerColumn' to make an instance to allow you to run queries on+-- your own datatypes. For example:+--+-- @+-- newtype Foo = Foo Int+-- instance Default QueryRunnerColumn Foo Foo where+-- def = queryRunnerColumn ('Opaleye.Column.unsafeCoerce' :: Column Foo -> Column PGInt4) Foo def+-- @+queryRunnerColumn :: (Column a' -> Column a) -> (b -> b')+ -> IRQ.QueryRunnerColumn a b -> IRQ.QueryRunnerColumn a' b'+queryRunnerColumn colF haskellF qrc = IRQ.QueryRunnerColumn (P.lmap colF u)+ (fmapFP haskellF fp)+ where IRQ.QueryRunnerColumn u fp = qrc+ fmapFP = fmap . fmap . fmap
+ src/Opaleye/Sql.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-}++module Opaleye.Sql where++import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ++import qualified Opaleye.Internal.Unpackspec as U+import qualified Opaleye.Internal.Sql as Sql+import qualified Opaleye.Internal.Print as Pr+import qualified Opaleye.Internal.PrimQuery as PQ+import qualified Opaleye.Internal.Optimize as Op+import Opaleye.Internal.Helpers ((.:))+import qualified Opaleye.Internal.QueryArr as Q+import qualified Opaleye.Internal.Tag as T++import qualified Data.Profunctor.Product.Default as D++-- | Example type specialization:+--+-- @+-- showSqlForPostgres :: Query (Column a, Column b) -> String+-- @+--+-- Assuming the @makeAdaptorAndInstance@ splice has been run for the+-- product type @Foo@:+--+-- @+-- showSqlForPostgres :: Query (Foo (Column a) (Column b) (Column c)) -> String+-- @+showSqlForPostgres :: forall columns . D.Default U.Unpackspec columns columns =>+ Q.Query columns -> String+showSqlForPostgres = showSqlForPostgresExplicit (D.def :: U.Unpackspec columns columns)++showSqlForPostgresUnopt :: forall columns . D.Default U.Unpackspec columns columns =>+ Q.Query columns -> String+showSqlForPostgresUnopt = showSqlForPostgresUnoptExplicit (D.def :: U.Unpackspec columns columns)++showSqlForPostgresExplicit :: U.Unpackspec columns b -> Q.Query columns -> String+showSqlForPostgresExplicit = formatAndShowSQL+ . (\(x, y, z) -> (x, Op.optimize y, z))+ .: Q.runQueryArrUnpack++showSqlForPostgresUnoptExplicit :: U.Unpackspec columns b -> Q.Query columns -> String+showSqlForPostgresUnoptExplicit = formatAndShowSQL .: Q.runQueryArrUnpack++formatAndShowSQL :: ([HPQ.PrimExpr], PQ.PrimQuery, T.Tag) -> String+formatAndShowSQL = show . Pr.ppSql . Sql.sql
+ src/Opaleye/Table.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE FlexibleContexts #-}++module Opaleye.Table (module Opaleye.Table,+ View,+ Writer,+ Table(Table),+ TableProperties) where++import Opaleye.Internal.Column (Column(Column))+import qualified Opaleye.Internal.QueryArr as Q+import qualified Opaleye.Internal.Table as T+import Opaleye.Internal.Table (View(View), Writer(Writer),+ Table, TableProperties)+import qualified Opaleye.Internal.TableMaker as TM+import qualified Opaleye.Internal.Tag as Tag+import qualified Opaleye.Internal.PackMap as PM++import qualified Data.Profunctor.Product.Default as D+import Control.Applicative (Applicative, pure)++import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ++-- | Example type specialization:+--+-- @+-- queryTable :: Table w (Column a, Column b) -> Query (Column a, Column b)+-- @+--+-- Assuming the @makeAdaptorAndInstance@ splice has been run for the+-- product type @Foo@:+--+-- @+-- queryTable :: Table w (Foo (Column a) (Column b) (Column c)) -> Query (Foo (Column a) (Column b) (Column c))+-- @+queryTable :: D.Default TM.ColumnMaker columns columns =>+ Table a columns -> Q.Query columns+queryTable = queryTableExplicit D.def++queryTableExplicit :: TM.ColumnMaker tablecolumns columns ->+ Table a tablecolumns -> Q.Query columns+queryTableExplicit cm table = Q.simpleQueryArr f where+ f ((), t0) = (retwires, primQ, Tag.next t0) where+ (retwires, primQ) = T.queryTable cm table t0++required :: String -> TableProperties (Column a) (Column a)+required columnName = T.TableProperties+ (Writer (PM.PackMap (\f (Column primExpr) -> f (primExpr, columnName))))+ (View (Column (HPQ.BaseTableAttrExpr columnName)))++optional :: String -> TableProperties (Maybe (Column a)) (Column a)+optional columnName = T.TableProperties+ (Writer (PM.PackMap (\f c -> case c of+ Nothing -> pure ()+ Just (Column primExpr) -> f (primExpr, columnName))))+ (View (Column (HPQ.BaseTableAttrExpr columnName)))
+ src/Opaleye/Values.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE FlexibleContexts #-}++module Opaleye.Values where++import qualified Opaleye.Internal.QueryArr as Q+import Opaleye.QueryArr (Query)+import Opaleye.Internal.Values as V+import qualified Opaleye.Internal.Unpackspec as U++import Data.Profunctor.Product.Default (Default, def)++-- | Example type specialization:+--+-- @+-- values :: [(Column a, Column b)] -> Query (Column a, Column b)+-- @+--+-- Assuming the @makeAdaptorAndInstance@ splice has been run for the+-- product type @Foo@:+--+-- @+-- queryTable :: [Foo (Column a) (Column b) (Column c)] -> Query (Foo (Column a) (Column b) (Column c))+-- @+values :: (Default V.Valuesspec columns columns,+ Default U.Unpackspec columns columns) =>+ [columns] -> Q.Query columns+values = valuesExplicit def def++valuesExplicit :: U.Unpackspec columns columns'+ -> V.Valuesspec columns columns'+ -> [columns] -> Query columns'+valuesExplicit unpack valuesspec columns =+ Q.simpleQueryArr (V.valuesU unpack valuesspec columns)