diff --git a/Doc/Tutorial/Main.hs b/Doc/Tutorial/Main.hs --- a/Doc/Tutorial/Main.hs +++ b/Doc/Tutorial/Main.hs @@ -1,5 +1,6 @@ -import TutorialBasic -import TutorialManipulation +import TutorialBasic () +import TutorialManipulation () +import TutorialAdvanced () main :: IO () main = return () diff --git a/Doc/Tutorial/TutorialAdvanced.lhs b/Doc/Tutorial/TutorialAdvanced.lhs new file mode 100644 --- /dev/null +++ b/Doc/Tutorial/TutorialAdvanced.lhs @@ -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 diff --git a/Doc/Tutorial/TutorialBasic.lhs b/Doc/Tutorial/TutorialBasic.lhs new file mode 100644 --- /dev/null +++ b/Doc/Tutorial/TutorialBasic.lhs @@ -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 diff --git a/Doc/Tutorial/TutorialManipulation.lhs b/Doc/Tutorial/TutorialManipulation.lhs new file mode 100644 --- /dev/null +++ b/Doc/Tutorial/TutorialManipulation.lhs @@ -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. diff --git a/Doc/UPGRADING.md b/Doc/UPGRADING.md new file mode 100644 --- /dev/null +++ b/Doc/UPGRADING.md @@ -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. diff --git a/Opaleye/Aggregate.hs b/Opaleye/Aggregate.hs deleted file mode 100644 --- a/Opaleye/Aggregate.hs +++ /dev/null @@ -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) diff --git a/Opaleye/Binary.hs b/Opaleye/Binary.hs deleted file mode 100644 --- a/Opaleye/Binary.hs +++ /dev/null @@ -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) diff --git a/Opaleye/Column.hs b/Opaleye/Column.hs deleted file mode 100644 --- a/Opaleye/Column.hs +++ /dev/null @@ -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 diff --git a/Opaleye/Distinct.hs b/Opaleye/Distinct.hs deleted file mode 100644 --- a/Opaleye/Distinct.hs +++ /dev/null @@ -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 diff --git a/Opaleye/Internal/Aggregate.hs b/Opaleye/Internal/Aggregate.hs deleted file mode 100644 --- a/Opaleye/Internal/Aggregate.hs +++ /dev/null @@ -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 - --- } diff --git a/Opaleye/Internal/Binary.hs b/Opaleye/Internal/Binary.hs deleted file mode 100644 --- a/Opaleye/Internal/Binary.hs +++ /dev/null @@ -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 - --- } diff --git a/Opaleye/Internal/Column.hs b/Opaleye/Internal/Column.hs deleted file mode 100644 --- a/Opaleye/Internal/Column.hs +++ /dev/null @@ -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 diff --git a/Opaleye/Internal/Distinct.hs b/Opaleye/Internal/Distinct.hs deleted file mode 100644 --- a/Opaleye/Internal/Distinct.hs +++ /dev/null @@ -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 - --- } diff --git a/Opaleye/Internal/HaskellDB/PrimQuery.hs b/Opaleye/Internal/HaskellDB/PrimQuery.hs deleted file mode 100644 --- a/Opaleye/Internal/HaskellDB/PrimQuery.hs +++ /dev/null @@ -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) diff --git a/Opaleye/Internal/HaskellDB/Query.hs b/Opaleye/Internal/HaskellDB/Query.hs deleted file mode 100644 --- a/Opaleye/Internal/HaskellDB/Query.hs +++ /dev/null @@ -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 diff --git a/Opaleye/Internal/HaskellDB/Sql.hs b/Opaleye/Internal/HaskellDB/Sql.hs deleted file mode 100644 --- a/Opaleye/Internal/HaskellDB/Sql.hs +++ /dev/null @@ -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] diff --git a/Opaleye/Internal/HaskellDB/Sql/Default.hs b/Opaleye/Internal/HaskellDB/Sql/Default.hs deleted file mode 100644 --- a/Opaleye/Internal/HaskellDB/Sql/Default.hs +++ /dev/null @@ -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] diff --git a/Opaleye/Internal/HaskellDB/Sql/Generate.hs b/Opaleye/Internal/HaskellDB/Sql/Generate.hs deleted file mode 100644 --- a/Opaleye/Internal/HaskellDB/Sql/Generate.hs +++ /dev/null @@ -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 - } diff --git a/Opaleye/Internal/HaskellDB/Sql/Print.hs b/Opaleye/Internal/HaskellDB/Sql/Print.hs deleted file mode 100644 --- a/Opaleye/Internal/HaskellDB/Sql/Print.hs +++ /dev/null @@ -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 diff --git a/Opaleye/Internal/Helpers.hs b/Opaleye/Internal/Helpers.hs deleted file mode 100644 --- a/Opaleye/Internal/Helpers.hs +++ /dev/null @@ -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) diff --git a/Opaleye/Internal/Join.hs b/Opaleye/Internal/Join.hs deleted file mode 100644 --- a/Opaleye/Internal/Join.hs +++ /dev/null @@ -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') - --- diff --git a/Opaleye/Internal/Optimize.hs b/Opaleye/Internal/Optimize.hs deleted file mode 100644 --- a/Opaleye/Internal/Optimize.hs +++ /dev/null @@ -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 _ = [] diff --git a/Opaleye/Internal/Order.hs b/Opaleye/Internal/Order.hs deleted file mode 100644 --- a/Opaleye/Internal/Order.hs +++ /dev/null @@ -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) diff --git a/Opaleye/Internal/PackMap.hs b/Opaleye/Internal/PackMap.hs deleted file mode 100644 --- a/Opaleye/Internal/PackMap.hs +++ /dev/null @@ -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 - --- } diff --git a/Opaleye/Internal/PrimQuery.hs b/Opaleye/Internal/PrimQuery.hs deleted file mode 100644 --- a/Opaleye/Internal/PrimQuery.hs +++ /dev/null @@ -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 diff --git a/Opaleye/Internal/Print.hs b/Opaleye/Internal/Print.hs deleted file mode 100644 --- a/Opaleye/Internal/Print.hs +++ /dev/null @@ -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 diff --git a/Opaleye/Internal/QueryArr.hs b/Opaleye/Internal/QueryArr.hs deleted file mode 100644 --- a/Opaleye/Internal/QueryArr.hs +++ /dev/null @@ -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 - (***!) = (***) diff --git a/Opaleye/Internal/RunQuery.hs b/Opaleye/Internal/RunQuery.hs deleted file mode 100644 --- a/Opaleye/Internal/RunQuery.hs +++ /dev/null @@ -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 - --- } diff --git a/Opaleye/Internal/Sql.hs b/Opaleye/Internal/Sql.hs deleted file mode 100644 --- a/Opaleye/Internal/Sql.hs +++ /dev/null @@ -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 diff --git a/Opaleye/Internal/Table.hs b/Opaleye/Internal/Table.hs deleted file mode 100644 --- a/Opaleye/Internal/Table.hs +++ /dev/null @@ -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) - --- } diff --git a/Opaleye/Internal/TableMaker.hs b/Opaleye/Internal/TableMaker.hs deleted file mode 100644 --- a/Opaleye/Internal/TableMaker.hs +++ /dev/null @@ -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 - ---} diff --git a/Opaleye/Internal/Tag.hs b/Opaleye/Internal/Tag.hs deleted file mode 100644 --- a/Opaleye/Internal/Tag.hs +++ /dev/null @@ -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 diff --git a/Opaleye/Internal/Unpackspec.hs b/Opaleye/Internal/Unpackspec.hs deleted file mode 100644 --- a/Opaleye/Internal/Unpackspec.hs +++ /dev/null @@ -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 - ---} diff --git a/Opaleye/Internal/Values.hs b/Opaleye/Internal/Values.hs deleted file mode 100644 --- a/Opaleye/Internal/Values.hs +++ /dev/null @@ -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 - --- } diff --git a/Opaleye/Join.hs b/Opaleye/Join.hs deleted file mode 100644 --- a/Opaleye/Join.hs +++ /dev/null @@ -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 diff --git a/Opaleye/Manipulation.hs b/Opaleye/Manipulation.hs deleted file mode 100644 --- a/Opaleye/Manipulation.hs +++ /dev/null @@ -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 diff --git a/Opaleye/Operators.hs b/Opaleye/Operators.hs deleted file mode 100644 --- a/Opaleye/Operators.hs +++ /dev/null @@ -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 diff --git a/Opaleye/Order.hs b/Opaleye/Order.hs deleted file mode 100644 --- a/Opaleye/Order.hs +++ /dev/null @@ -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) diff --git a/Opaleye/PGTypes.hs b/Opaleye/PGTypes.hs deleted file mode 100644 --- a/Opaleye/PGTypes.hs +++ /dev/null @@ -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 diff --git a/Opaleye/QueryArr.hs b/Opaleye/QueryArr.hs deleted file mode 100644 --- a/Opaleye/QueryArr.hs +++ /dev/null @@ -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) diff --git a/Opaleye/RunQuery.hs b/Opaleye/RunQuery.hs deleted file mode 100644 --- a/Opaleye/RunQuery.hs +++ /dev/null @@ -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 diff --git a/Opaleye/Sql.hs b/Opaleye/Sql.hs deleted file mode 100644 --- a/Opaleye/Sql.hs +++ /dev/null @@ -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 diff --git a/Opaleye/Table.hs b/Opaleye/Table.hs deleted file mode 100644 --- a/Opaleye/Table.hs +++ /dev/null @@ -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))) diff --git a/Opaleye/Values.hs b/Opaleye/Values.hs deleted file mode 100644 --- a/Opaleye/Values.hs +++ /dev/null @@ -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) diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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. diff --git a/TODO.md b/TODO.md new file mode 100644 --- /dev/null +++ b/TODO.md @@ -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 diff --git a/Test/Test.hs b/Test/Test.hs --- a/Test/Test.hs +++ b/Test/Test.hs @@ -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) diff --git a/opaleye.cabal b/opaleye.cabal --- a/opaleye.cabal +++ b/opaleye.cabal @@ -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 diff --git a/src/Opaleye.hs b/src/Opaleye.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye.hs @@ -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 diff --git a/src/Opaleye/Aggregate.hs b/src/Opaleye/Aggregate.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/Aggregate.hs @@ -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 diff --git a/src/Opaleye/Binary.hs b/src/Opaleye/Binary.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/Binary.hs @@ -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) diff --git a/src/Opaleye/Column.hs b/src/Opaleye/Column.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/Column.hs @@ -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)) diff --git a/src/Opaleye/Distinct.hs b/src/Opaleye/Distinct.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/Distinct.hs @@ -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 diff --git a/src/Opaleye/Internal/Aggregate.hs b/src/Opaleye/Internal/Aggregate.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/Internal/Aggregate.hs @@ -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 + +-- } diff --git a/src/Opaleye/Internal/Binary.hs b/src/Opaleye/Internal/Binary.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/Internal/Binary.hs @@ -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 + +-- } diff --git a/src/Opaleye/Internal/Column.hs b/src/Opaleye/Internal/Column.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/Internal/Column.hs @@ -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 diff --git a/src/Opaleye/Internal/Distinct.hs b/src/Opaleye/Internal/Distinct.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/Internal/Distinct.hs @@ -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 + +-- } diff --git a/src/Opaleye/Internal/HaskellDB/PrimQuery.hs b/src/Opaleye/Internal/HaskellDB/PrimQuery.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/Internal/HaskellDB/PrimQuery.hs @@ -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) diff --git a/src/Opaleye/Internal/HaskellDB/Sql.hs b/src/Opaleye/Internal/HaskellDB/Sql.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/Internal/HaskellDB/Sql.hs @@ -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] diff --git a/src/Opaleye/Internal/HaskellDB/Sql/Default.hs b/src/Opaleye/Internal/HaskellDB/Sql/Default.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/Internal/HaskellDB/Sql/Default.hs @@ -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] diff --git a/src/Opaleye/Internal/HaskellDB/Sql/Generate.hs b/src/Opaleye/Internal/HaskellDB/Sql/Generate.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/Internal/HaskellDB/Sql/Generate.hs @@ -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 + } diff --git a/src/Opaleye/Internal/HaskellDB/Sql/Print.hs b/src/Opaleye/Internal/HaskellDB/Sql/Print.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/Internal/HaskellDB/Sql/Print.hs @@ -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 diff --git a/src/Opaleye/Internal/Helpers.hs b/src/Opaleye/Internal/Helpers.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/Internal/Helpers.hs @@ -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) diff --git a/src/Opaleye/Internal/Join.hs b/src/Opaleye/Internal/Join.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/Internal/Join.hs @@ -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') + +-- diff --git a/src/Opaleye/Internal/Optimize.hs b/src/Opaleye/Internal/Optimize.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/Internal/Optimize.hs @@ -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 _ = [] diff --git a/src/Opaleye/Internal/Order.hs b/src/Opaleye/Internal/Order.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/Internal/Order.hs @@ -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) diff --git a/src/Opaleye/Internal/PackMap.hs b/src/Opaleye/Internal/PackMap.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/Internal/PackMap.hs @@ -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 + +-- } diff --git a/src/Opaleye/Internal/PrimQuery.hs b/src/Opaleye/Internal/PrimQuery.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/Internal/PrimQuery.hs @@ -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 diff --git a/src/Opaleye/Internal/Print.hs b/src/Opaleye/Internal/Print.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/Internal/Print.hs @@ -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 diff --git a/src/Opaleye/Internal/QueryArr.hs b/src/Opaleye/Internal/QueryArr.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/Internal/QueryArr.hs @@ -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 + (***!) = (***) diff --git a/src/Opaleye/Internal/RunQuery.hs b/src/Opaleye/Internal/RunQuery.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/Internal/RunQuery.hs @@ -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 + +-- } diff --git a/src/Opaleye/Internal/Sql.hs b/src/Opaleye/Internal/Sql.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/Internal/Sql.hs @@ -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))) diff --git a/src/Opaleye/Internal/Table.hs b/src/Opaleye/Internal/Table.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/Internal/Table.hs @@ -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) + +-- } diff --git a/src/Opaleye/Internal/TableMaker.hs b/src/Opaleye/Internal/TableMaker.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/Internal/TableMaker.hs @@ -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 + +--} diff --git a/src/Opaleye/Internal/Tag.hs b/src/Opaleye/Internal/Tag.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/Internal/Tag.hs @@ -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) diff --git a/src/Opaleye/Internal/Unpackspec.hs b/src/Opaleye/Internal/Unpackspec.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/Internal/Unpackspec.hs @@ -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 + +--} diff --git a/src/Opaleye/Internal/Values.hs b/src/Opaleye/Internal/Values.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/Internal/Values.hs @@ -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 + +-- } diff --git a/src/Opaleye/Join.hs b/src/Opaleye/Join.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/Join.hs @@ -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 diff --git a/src/Opaleye/Manipulation.hs b/src/Opaleye/Manipulation.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/Manipulation.hs @@ -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 diff --git a/src/Opaleye/Operators.hs b/src/Opaleye/Operators.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/Operators.hs @@ -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 diff --git a/src/Opaleye/Order.hs b/src/Opaleye/Order.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/Order.hs @@ -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) diff --git a/src/Opaleye/PGTypes.hs b/src/Opaleye/PGTypes.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/PGTypes.hs @@ -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 diff --git a/src/Opaleye/QueryArr.hs b/src/Opaleye/QueryArr.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/QueryArr.hs @@ -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) diff --git a/src/Opaleye/RunQuery.hs b/src/Opaleye/RunQuery.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/RunQuery.hs @@ -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 diff --git a/src/Opaleye/Sql.hs b/src/Opaleye/Sql.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/Sql.hs @@ -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 diff --git a/src/Opaleye/Table.hs b/src/Opaleye/Table.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/Table.hs @@ -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))) diff --git a/src/Opaleye/Values.hs b/src/Opaleye/Values.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/Values.hs @@ -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)