diff --git a/Doc/Tutorial/DefaultExplanation.lhs b/Doc/Tutorial/DefaultExplanation.lhs new file mode 100644 --- /dev/null +++ b/Doc/Tutorial/DefaultExplanation.lhs @@ -0,0 +1,228 @@ +> {-# LANGUAGE FlexibleContexts #-} +> module DefaultExplanation where +> +> import Opaleye.SQLite (Column, Nullable, QueryRunner, Query, +> PGInt4, PGBool, PGText, PGFloat4) +> import qualified Opaleye.SQLite as O +> import qualified Opaleye.SQLite.Internal.Binary as Internal.Binary +> import Opaleye.SQLite.Internal.Binary (Binaryspec) +> +> import Data.Profunctor.Product ((***!), p4) +> import Data.Profunctor.Product.Default (Default, def) +> import qualified Database.SQLite.Simple as SQL + +Introduction +============ + +Instances of `ProductProfunctor` are very common in Opaleye. They are +first-class representations of various transformations that need to +occur in certain places. The `Default` typeclass from +product-profunctors is used throughout Opaleye to avoid API users +having to write a lot of automatically derivable code, and it deserves +a thorough explanation. + +Example +======= + +By way of example we will consider the Binaryspec product-profunctor +and how it is used with the `unionAll` operation. The version of +`unionAll` that does not have a Default constraint is called +`unionAllExplicit` and has the following type. + +> unionAllExplicit :: Binaryspec a b -> Query a -> Query a -> Query b +> unionAllExplicit = O.unionAllExplicit + +What is the `Binaryspec` used for here? Let's take a simple case +where we want to union two queries of type `Query (Column PGInt4, +Column PGText)` + +> myQuery1 :: Query (Column PGInt4, Column PGText) +> myQuery1 = undefined -- We won't actually need specific implementations here +> +> myQuery2 :: Query (Column PGInt4, Column PGText) +> myQuery2 = undefined + +That means we will be using unionAll at the type + +> unionAllExplicit' :: Binaryspec (Column PGInt4, Column PGText) (Column PGInt4, Column PGText) +> -> Query (Column PGInt4, Column PGText) +> -> Query (Column PGInt4, Column PGText) +> -> Query (Column PGInt4, Column PGText) +> unionAllExplicit' = unionAllExplicit + +Since every `Column` is actually just a string containing an SQL +expression, `(Column PGInt4, Column PGText)` is a pair of expressions. +When we generate the SQL we need to take the two pairs of expressions, +generate new unique names that refer to them and produce these new +unique names in another value of type `(Column PGInt4, Column +PGText)`. This is exactly what a value of type + + Binaryspec (Column PGInt4, Column PGText) (Column PGInt4, Column PGText) + +allows us to do. + +So the next question is, how do we get our hands on a value of that +type? Well, we have `binaryspecColumn` which is a value that allows +us to access the column name within a single column. + +> binaryspecColumn :: Binaryspec (Column a) (Column a) +> binaryspecColumn = Internal.Binary.binaryspecColumn + +`Binaryspec` is a `ProductProfunctor` so we can combine two of them to +work on a pair. + +> binaryspecColumn2 :: Binaryspec (Column a, Column b) (Column a, Column b) +> binaryspecColumn2 = binaryspecColumn ***! binaryspecColumn + +Then we can use `binaryspecColumn2` in `unionAllExplicit`. + +> theUnionAll :: Query (Column PGInt4, Column PGText) +> theUnionAll = unionAllExplicit binaryspecColumn2 myQuery1 myQuery2 + +Now suppose that we wanted to take a union of two queries with columns +in a tuple of size four. We can make a suitable `Binaryspec` like +this: + +> binaryspecColumn4 :: Binaryspec (Column a, Column b, Column c, Column d) +> (Column a, Column b, Column c, Column d) +> binaryspecColumn4 = p4 (binaryspecColumn, binaryspecColumn, +> binaryspecColumn, binaryspecColumn) + +Then we can pass this `Binaryspec` to `unionAllExplicit`. + +The problem and 'Default' is the solution +========================================= + +Constructing these `Binaryspec`s explicitly will become very tedious +very fast. Furthermore it is completely pointless to construct them +explicitly because the correct `Binaryspec` can automatically be +deduced. This is where the `Default` typeclass comes in. + +`Opaleye.Internal.Binary` contains the `Default` instance + + instance Default Binaryspec (Column a) (Column a) where + def = binaryspecColumn + +That means that we know the "default" way of getting a + + Binaryspec (Column a) (Column a) + +However, if we have a default way of getting one of these, we also +have a default way of getting a + + Binaryspec (Column a, Column b) (Column a, Column b) + +just by using the `ProductProfunctor` product operation `(***!)`. And +in the general case for a product type `T` with n type parameters we +can automatically deduce the correct value of type + + Binaryspec (T a1 ... an) (T a1 ... an) + +(This requires the `Default` instance for `T` as generated by +`Data.Profunctor.Product.TH.makeAdaptorAndInstance`, or an equivalent +instance defined by hand). It means we don't have to explicitly +specify the `Binaryspec` value. + +Instead of writing `theUnionAll` as above, providing the `Binaryspec` +explicitly, we can instead use a version of `unionAll` which +automatically uses the default `Binaryspec` so we don't have to +provide it. This is exactly what `Opaleye.Binary.unionAll` does. + +> unionAll :: Default Binaryspec a b +> => Query a -> Query a -> Query b +> unionAll = O.unionAllExplicit def +> +> theUnionAll' :: Query (Column PGInt4, Column PGText) +> theUnionAll' = unionAll myQuery1 myQuery2 + +In the long run this prevents writing a huge amount of boilerplate code. + +A further example: `QueryRunner` +============================== + +A `QueryRunner a b` is the product-profunctor which represents how to +turn run a `Query a` (currently on Postgres) and return you a list of +rows, each row of type `b`. The function which is responsible for +this is `runQuery` + +> runQueryExplicit :: QueryRunner a b -> SQL.Connection -> Query a -> IO [b] +> runQueryExplicit = O.runQueryExplicit + +Basic values of `QueryRunner` will have the following types + +> intRunner :: QueryRunner (Column PGInt4) Int +> intRunner = undefined -- The implementation is not important here +> +> doubleRunner :: QueryRunner (Column PGFloat4) Double +> doubleRunner = undefined +> +> stringRunner :: QueryRunner (Column PGText) String +> stringRunner = undefined +> +> boolRunner :: QueryRunner (Column PGBool) Bool +> boolRunner = undefined + +Furthermore we will have basic ways of running queries which return +`Nullable` values, for example + +> nullableIntRunner :: QueryRunner (Column (Nullable PGInt4)) (Maybe Int) +> nullableIntRunner = undefined + +If I have a very simple query with a single column of `PGInt4` then I can +run it using the `intRunner`. + +> myQuery3 :: Query (Column PGInt4) +> myQuery3 = undefined -- The implementation is not important +> +> runTheQuery :: SQL.Connection -> IO [Int] +> runTheQuery c = runQueryExplicit intRunner c myQuery3 + +If my query has several columns of different types I need to build up +a larger `QueryRunner`. + +> myQuery4 :: Query (Column PGInt4, Column PGText, Column PGBool, Column (Nullable PGInt4)) +> myQuery4 = undefined +> +> largerQueryRunner :: QueryRunner +> (Column PGInt4, Column PGText, Column PGBool, Column (Nullable PGInt4)) +> (Int, String, Bool, Maybe Int) +> largerQueryRunner = p4 (intRunner, stringRunner, boolRunner, nullableIntRunner) +> +> runTheBiggerQuery :: SQL.Connection -> IO [(Int, String, Bool, Maybe Int)] +> runTheBiggerQuery c = runQueryExplicit largerQueryRunner c myQuery4 + +But having to build up `largerQueryRunner` was a pain and completely +redundant! Like the `Binaryspec` it can be automatically deduced. +`Karamaan.Opaleye.RunQuery` already gives us `Default` instances for +the following types (plus many others, of course!). + +* `QueryRunner (Column PGInt4) Int` +* `QueryRunner (Column PGText) String` +* `QueryRunner (Column Bool) Bool` +* `QueryRunner (Column (Nullable Int)) (Maybe Int)` + +Then the `Default` typeclass machinery automatically deduces the +correct value of the type we want. + +> largerQueryRunner' :: QueryRunner +> (Column PGInt4, Column PGText, Column PGBool, Column (Nullable PGInt4)) +> (Int, String, Bool, Maybe Int) +> largerQueryRunner' = def + +And we can produce a version of `runQuery` which allows us to write +our query without explicitly passing the product-profunctor value. + +> runQuery :: Default QueryRunner a b => SQL.Connection -> Query a -> IO [b] +> runQuery = O.runQueryExplicit def +> +> runTheBiggerQuery' :: SQL.Connection -> IO [(Int, String, Bool, Maybe Int)] +> runTheBiggerQuery' c = runQuery c myQuery4 + +Conclusion +========== + +Much of the functionality of Opaleye depends on product-profunctors +and many of the values of the product-profunctors are automatically +derivable from some base collection. The `Default` typeclass and its +associated instance derivations are the mechanism through which this +happens. diff --git a/Doc/Tutorial/Main.hs b/Doc/Tutorial/Main.hs new file mode 100644 --- /dev/null +++ b/Doc/Tutorial/Main.hs @@ -0,0 +1,7 @@ +import TutorialBasic () +import TutorialManipulation () +import TutorialAdvanced () +import DefaultExplanation () + +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.SQLite.QueryArr (Query) +> import Opaleye.SQLite.Column (Column) +> import Opaleye.SQLite.Table (Table(Table), required, queryTable) +> import Opaleye.SQLite.PGTypes (PGText, PGInt4) +> import qualified Opaleye.SQLite.Aggregate as A +> import Opaleye.SQLite.Aggregate (Aggregator, aggregate) +> +> import qualified Opaleye.SQLite.Sql as Sql +> import qualified Opaleye.SQLite.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,840 @@ +> {-# LANGUAGE Arrows #-} +> {-# LANGUAGE FlexibleContexts #-} +> {-# LANGUAGE FlexibleInstances #-} +> {-# LANGUAGE MultiParamTypeClasses #-} +> {-# LANGUAGE TemplateHaskell #-} +> +> module TutorialBasic where +> +> import Prelude hiding (sum) +> +> import Opaleye.SQLite (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.SQLite.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 to reduce boilerplate. 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, + 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 + + +A comment about type signatures +------------------------------- + +We mentioned that Opaleye uses typeclass magic behind the scenes to +avoid boilerplate. One consequence of this is that the compiler +cannot infer types in some cases. Use of `leftJoin` is one of those +cases. You will generally need to provide a type signature yourself. +If you see the compiler complain that it cannot determine a `Default` +instance then specify more types. + + +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. Like `leftJoin` this particular formulation uses +typeclasses so 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,124 @@ +> module TutorialManipulation where +> +> import Prelude hiding (sum) +> +> import Opaleye.SQLite (Column, Table(Table), +> required, optional, (.==), (.<), +> arrangeDeleteSql, arrangeInsertSql, +> arrangeUpdateSql, arrangeInsertReturningSql, +> PGInt4, PGFloat8) +> +> import Data.Profunctor.Product (p3) +> import Data.Profunctor.Product.Default (Default, def) +> import qualified Opaleye.SQLite.Internal.Unpackspec as U + + +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_) +> -- TODO: vv This is too messy +> where def' :: U.Unpackspec (Column a) (Column a) +> def' = def + +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/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,4 @@ +# `opaleye-sqlite` + +A preliminary version of Opaleye for SQLite. There may be many rough +edges! diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Test/QuickCheck.hs b/Test/QuickCheck.hs new file mode 100644 --- /dev/null +++ b/Test/QuickCheck.hs @@ -0,0 +1,327 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE Rank2Types #-} + +module QuickCheck where + +import qualified Opaleye.SQLite as O +import qualified Database.SQLite.Simple as PGS +import qualified Test.QuickCheck as TQ +import Control.Applicative (Applicative, pure, (<$>), (<*>), liftA2) +import qualified Data.Profunctor.Product.Default as D +import Data.List (sort, sortBy) +import qualified Data.Profunctor.Product as PP +import qualified Data.Functor.Contravariant.Divisible as Divisible +import qualified Data.Monoid as Monoid +import qualified Data.Ord as Ord +import qualified Data.Set as Set +import qualified Data.Maybe as Maybe +import qualified Control.Arrow as Arrow + +twoIntTable :: String + -> O.Table (O.Column O.PGInt4, O.Column O.PGInt4) + (O.Column O.PGInt4, O.Column O.PGInt4) +twoIntTable n = O.Table n (PP.p2 (O.required "column1", O.required "column2")) + +table1 :: O.Table (O.Column O.PGInt4, O.Column O.PGInt4) + (O.Column O.PGInt4, O.Column O.PGInt4) +table1 = twoIntTable "table1" + +data QueryDenotation a = + QueryDenotation { unQueryDenotation :: PGS.Connection -> IO [a] } + +onList :: ([a] -> [b]) -> QueryDenotation a -> QueryDenotation b +onList f = QueryDenotation . (fmap . fmap) f . unQueryDenotation + +type Columns = [Either (O.Column O.PGInt4) (O.Column O.PGBool)] +type Haskells = [Either Int Bool] + +newtype ArbitraryQuery = ArbitraryQuery (O.Query Columns) +newtype ArbitraryColumns = ArbitraryColumns { unArbitraryColumns :: Columns } + deriving Show +newtype ArbitraryPositiveInt = ArbitraryPositiveInt Int + deriving Show +newtype ArbitraryOrder = ArbitraryOrder { unArbitraryOrder :: [(Order, Int)] } + deriving Show +newtype ArbitraryGarble = + ArbitraryGarble { unArbitraryGarble :: forall a. [a] -> [a] } + +data Order = Asc | Desc deriving Show + +unpackColumns :: O.Unpackspec Columns Columns +unpackColumns = eitherPP + +instance Show ArbitraryQuery where + show (ArbitraryQuery q) = O.showSqlForPostgresExplicit unpackColumns q + +instance Show ArbitraryGarble where + show = const "A permutation" + +instance TQ.Arbitrary ArbitraryQuery where + arbitrary = TQ.sized arbitraryQuery + +arbitraryQuery :: Int -> TQ.Gen ArbitraryQuery +arbitraryQuery size | size == 0 = (pure . ArbitraryQuery . pure) [] + | otherwise = TQ.oneof [ + (ArbitraryQuery . pure . unArbitraryColumns) + <$> TQ.arbitrary + , return (ArbitraryQuery (fmap (\(x,y) -> [Left x, Left y]) (O.queryTable table1))) + , do + ArbitraryQuery q <- arbitraryQuery size' + aq (O.distinctExplicit eitherPP q) +{- Limit introduces non-determinism + To get around non-determinism we should ORDER BY first and then LIMIT. + We should probably just ORDER BY the first column, or if there is none, + order doesn't matter! + , do + ArbitraryQuery q <- arbitraryQuery size' + l <- TQ.choose (0, 100) + aq (O.limit l q) +-} +{- Offset has a syntactic problem, and also presumably introduces nondeterminism + To get around non-determinism we should ORDER BY first and then LIMIT. + We should probably just ORDER BY the first column, or if there is none, + order doesn't matter! + , do + ArbitraryQuery q <- TQ.arbitrary + l <- TQ.choose (0, 100) + aq (O.offset l q) +-} + , do + ArbitraryQuery q <- arbitraryQuery size' + o <- TQ.arbitrary + aq (O.orderBy (arbitraryOrder o) q) + + , do + ArbitraryQuery q <- arbitraryQuery size' + f <- TQ.arbitrary + aq (fmap (unArbitraryGarble f) q) + + , do + ArbitraryQuery q <- arbitraryQuery size' + aq (restrictFirstBool Arrow.<<< q) + ] + where aq = return . ArbitraryQuery + size' = size - 1 + + +instance TQ.Arbitrary ArbitraryColumns where + arbitrary = do + l <- TQ.listOf (TQ.oneof (map (return . Left) [-1, 0, 1] + ++ map (return . Right) [O.pgBool False, O.pgBool True])) + return (ArbitraryColumns l) + +instance TQ.Arbitrary ArbitraryPositiveInt where + arbitrary = fmap ArbitraryPositiveInt (TQ.choose (0, 100)) + +instance TQ.Arbitrary ArbitraryOrder where + arbitrary = fmap ArbitraryOrder + (TQ.listOf ((,) + <$> TQ.oneof [return Asc, return Desc] + <*> TQ.choose (0, 100))) + +odds :: [a] -> [a] +odds [] = [] +odds (x:xs) = x : evens xs + +evens :: [a] -> [a] +evens [] = [] +evens (_:xs) = odds xs + +instance TQ.Arbitrary ArbitraryGarble where + arbitrary = do + i <- TQ.choose (0 :: Int, 4) + + return (ArbitraryGarble (\xs -> + if i == 0 then + evens xs ++ odds xs + else if i == 1 then + evens xs ++ evens xs + else if i == 2 then + odds xs ++ odds xs + else if i == 3 then + evens xs + else + odds xs)) + +arbitraryOrder :: ArbitraryOrder -> O.Order Columns +arbitraryOrder = Monoid.mconcat + . map (\(direction, index) -> + (case direction of + Asc -> (\f -> Divisible.choose f (O.asc id) (O.asc id)) + Desc -> (\f -> Divisible.choose f (O.desc id) (O.desc id))) + -- If the list is empty we have to conjure up + -- an arbitrary value of type Column + (\l -> let len = length l + in if len > 0 then + l !! (index `mod` length l) + else + Left 0)) + . unArbitraryOrder + +arbitraryOrdering :: ArbitraryOrder -> Haskells -> Haskells -> Ord.Ordering +arbitraryOrdering = Monoid.mconcat + . map (\(direction, index) -> + (case direction of + Asc -> id + Desc -> flip) + -- If the list is empty we have to conjure up + -- an arbitrary value of type Column + -- + -- Note that this one will compare Left Int + -- to Right Bool, but it never gets asked to + -- do so, so we don't care. + (Ord.comparing (\l -> let len = length l + in if len > 0 then + l !! (index `mod` length l) + else + Left 0))) + . unArbitraryOrder + +instance Functor QueryDenotation where + fmap f = QueryDenotation . (fmap . fmap . fmap) f .unQueryDenotation + +instance Applicative QueryDenotation where + pure = QueryDenotation . pure . pure . pure + f <*> x = QueryDenotation ((liftA2 . liftA2 . liftA2) ($) + (unQueryDenotation f) (unQueryDenotation x)) + +denotation :: O.QueryRunner columns a -> O.Query columns -> QueryDenotation a +denotation qr q = QueryDenotation (\conn -> O.runQueryExplicit qr conn q) + +denotation' :: O.Query Columns -> QueryDenotation Haskells +denotation' = denotation eitherPP + +denotation2 :: O.Query (Columns, Columns) + -> QueryDenotation (Haskells, Haskells) +denotation2 = denotation (eitherPP PP.***! eitherPP) + +-- { Comparing the results + +compareNoSort :: Eq a + => PGS.Connection + -> QueryDenotation a + -> QueryDenotation a + -> IO Bool +compareNoSort conn one two = do + one' <- unQueryDenotation one conn + two' <- unQueryDenotation two conn + return (one' == two') + +compare' :: Ord a + => PGS.Connection + -> QueryDenotation a + -> QueryDenotation a + -> IO Bool +compare' conn one two = do + one' <- unQueryDenotation one conn + two' <- unQueryDenotation two conn + return (sort one' == sort two') + +-- } + +-- { The tests + +fmap' :: PGS.Connection -> ArbitraryGarble -> ArbitraryQuery -> IO Bool +fmap' conn f (ArbitraryQuery q) = do + compareNoSort conn (denotation' (fmap (unArbitraryGarble f) q)) + (onList (fmap (unArbitraryGarble f)) (denotation' q)) + +apply :: PGS.Connection -> ArbitraryQuery -> ArbitraryQuery -> IO Bool +apply conn (ArbitraryQuery q1) (ArbitraryQuery q2) = do + compare' conn (denotation2 ((,) <$> q1 <*> q2)) + ((,) <$> denotation' q1 <*> denotation' q2) + +limit :: PGS.Connection -> ArbitraryPositiveInt -> ArbitraryQuery -> IO Bool +limit conn (ArbitraryPositiveInt l) (ArbitraryQuery q) = do + compareNoSort conn (denotation' (O.limit l q)) + (onList (take l) (denotation' q)) + +offset :: PGS.Connection -> ArbitraryPositiveInt -> ArbitraryQuery -> IO Bool +offset conn (ArbitraryPositiveInt l) (ArbitraryQuery q) = do + compareNoSort conn (denotation' (O.offset l q)) + (onList (drop l) (denotation' q)) + +order :: PGS.Connection -> ArbitraryOrder -> ArbitraryQuery -> IO Bool +order conn o (ArbitraryQuery q) = do + compareNoSort conn (denotation' (O.orderBy (arbitraryOrder o) q)) + (onList (sortBy (arbitraryOrdering o)) (denotation' q)) + +distinct :: PGS.Connection -> ArbitraryQuery -> IO Bool +distinct conn (ArbitraryQuery q) = do + compare' conn (denotation' (O.distinctExplicit eitherPP q)) + (onList nub (denotation' q)) + +restrict :: PGS.Connection -> ArbitraryQuery -> IO Bool +restrict conn (ArbitraryQuery q) = do + compareNoSort conn (denotation' (restrictFirstBool Arrow.<<< q)) + (onList restrictFirstBoolList (denotation' q)) + +-- } + +-- { Running the QuickCheck + +run :: PGS.Connection -> IO () +run conn = do + let propFmap = (fmap . fmap) TQ.ioProperty (fmap' conn) + propApply = (fmap . fmap) TQ.ioProperty (apply conn) + propLimit = (fmap . fmap) TQ.ioProperty (limit conn) +-- propOffset = (fmap . fmap) TQ.ioProperty (offset conn) + propOrder = (fmap . fmap) TQ.ioProperty (order conn) + propDistinct = fmap TQ.ioProperty (distinct conn) + propRestrict = fmap TQ.ioProperty (restrict conn) + + -- 5 seems to be the max size of test cases before SQLite's stack overflows. + -- I'd rather increase the stack size + -- http://www.sqlite.org/limits.html#max_expr_depth + -- but I don't know how to do that from Haskell. + -- Increasing the number of trials to compensate. + let t p = errorIfNotSuccess =<< TQ.quickCheckWithResult (TQ.stdArgs { TQ.maxSuccess = 10000 + , TQ.maxSize = 5 }) p + + t propFmap + t propApply + t propLimit +-- t propOffset + t propOrder + t propDistinct + t propRestrict + +-- } + +-- { Utilities + +nub :: Ord a => [a] -> [a] +nub = Set.toList . Set.fromList + +eitherPP :: (D.Default p a a', D.Default p b b', + PP.SumProfunctor p, PP.ProductProfunctor p) + => p [Either a b] [Either a' b'] +eitherPP = PP.list (D.def PP.+++! D.def) + +errorIfNotSuccess :: TQ.Result -> IO () +errorIfNotSuccess r = case r of + TQ.Success _ _ _ -> return () + _ -> error "Failed" + +firstBoolOrTrue :: b -> [Either a b] -> (b, [Either a b]) +firstBoolOrTrue true c = (b, c) + where b = case Maybe.mapMaybe isBool c of + [] -> true + (x:_) -> x + +isBool :: Either a b + -> Maybe b +isBool (Left _) = Nothing +isBool (Right l) = Just l + +restrictFirstBool :: O.QueryArr Columns Columns +restrictFirstBool = Arrow.arr snd + Arrow.<<< Arrow.first O.restrict + Arrow.<<< Arrow.arr (firstBoolOrTrue (O.pgBool True)) + +restrictFirstBoolList :: [Haskells] -> [Haskells] +restrictFirstBoolList = map snd + . filter fst + . map (firstBoolOrTrue True) + +-- } diff --git a/Test/Test.hs b/Test/Test.hs new file mode 100644 --- /dev/null +++ b/Test/Test.hs @@ -0,0 +1,602 @@ +{-# LANGUAGE Arrows #-} +{-# LANGUAGE FlexibleContexts #-} + +module Main where + +import qualified QuickCheck + +import Opaleye.SQLite (Column, Nullable, Query, QueryArr, (.==), (.>)) +import qualified Opaleye.SQLite as O + +import qualified Database.SQLite.Simple as PGS +import qualified Data.Profunctor.Product.Default as D +import qualified Data.Profunctor.Product as PP +import qualified Data.Profunctor as P +import qualified Data.Ord as Ord +import qualified Data.List as L +import Data.Monoid ((<>)) +import qualified Data.String as String + +import qualified System.Exit as Exit +import qualified System.Environment as Environment + +import qualified Control.Applicative as A +import qualified Control.Arrow as Arr +import Control.Arrow ((&&&), (***), (<<<), (>>>)) + +import GHC.Int (Int64) + +{- + +Status +====== + +The tests here are very superficial and pretty much the bare mininmum +that needs to be tested. + + +Future +====== + +The overall approach to testing should probably go as follows. + +1. Test all individual units of functionality by running them on a + table and checking that they produce the expected result. This type + of testing is amenable to the QuickCheck approach if we reimplement + the individual units of functionality in Haskell. + +2. Test that "the denotation is an arrow morphism" is correct. I + think in combination with 1. this is all that will be required to + demonstrate that the library is correct. + + "The denotation is an arrow morphism" means that for each arrow + operation, the denotation preserves the operation. If we have + + f :: QueryArr wiresa wiresb + + then [f] should be something like + + [f] :: a -> IO [b] + f as = runQuery (toValues as >>> f) + + For example, take the operation >>>. We need to check that + + [f >>> g] = [f] >>> [g] + + for all f and g, where [] means the denotation. We would also want + to check that + + [id] = id + + and + + [first f] = first [f] + + I think checking these operations is sufficient because all the + other QueryArr operations are implemented in terms of them. + + (Here I'm taking a slight liberty as `a -> IO [b]` is not directly + an arrow, but it could be made one straightforwardly. (For the laws + to be satisfied, perhaps we have to assume that the IO actions + commute.)) + + I don't think this type of testing is amenable to QuickCheck. It + seems we have to check the properties for arbitrary arrows indexed by + arbitrary types. I don't think QuickCheck supports this sort of + randomised testing. + +Note +---- + +This seems to be equivalent to just reimplementing Opaleye in +Haskell-side terms and comparing the results of queries run in both +ways. + +-} + +twoIntTable :: String + -> 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 :: O.Table (Column O.PGInt4, Column O.PGInt4) (Column O.PGInt4, Column O.PGInt4) +table1 = twoIntTable "table1" + +table1F :: O.Table (Column O.PGInt4, Column O.PGInt4) (Column O.PGInt4, Column O.PGInt4) +table1F = fmap (\(col1, col2) -> (col1 + col2, col1 - col2)) table1 + +-- This is implicitly testing our ability to handle upper case letters in table names. +table2 :: O.Table (Column O.PGInt4, Column O.PGInt4) (Column O.PGInt4, Column O.PGInt4) +table2 = twoIntTable "TABLE2" + +table3 :: O.Table (Column O.PGInt4, Column O.PGInt4) (Column O.PGInt4, Column O.PGInt4) +table3 = twoIntTable "table3" + +table4 :: O.Table (Column O.PGInt4, Column O.PGInt4) (Column O.PGInt4, Column O.PGInt4) +table4 = twoIntTable "table4" + +table5 :: O.Table (Maybe (Column O.PGInt4), Maybe (Column O.PGInt4)) + (Column O.PGInt4, Column O.PGInt4) +table5 = O.Table "table5" (PP.p2 (O.optional "column1", O.optional "column2")) + +table6 :: O.Table (Column O.PGText, Column O.PGText) (Column O.PGText, Column O.PGText) +table6 = O.Table "table6" (PP.p2 (O.required "column1", O.required "column2")) + +tableKeywordColNames :: O.Table (Column O.PGInt4, Column O.PGInt4) + (Column O.PGInt4, Column O.PGInt4) +tableKeywordColNames = O.Table "keywordtable" (PP.p2 (O.required "column", O.required "where")) + +table1Q :: Query (Column O.PGInt4, Column O.PGInt4) +table1Q = O.queryTable table1 + +table2Q :: Query (Column O.PGInt4, Column O.PGInt4) +table2Q = O.queryTable table2 + +table3Q :: Query (Column O.PGInt4, Column O.PGInt4) +table3Q = O.queryTable table3 + +table6Q :: Query (Column O.PGText, Column O.PGText) +table6Q = O.queryTable table6 + +table1dataG :: Num a => [(a, a)] +table1dataG = [ (1, 100) + , (1, 100) + , (1, 200) + , (2, 300) ] + +table1data :: [(Int, Int)] +table1data = table1dataG + +table1columndata :: [(Column O.PGInt4, Column O.PGInt4)] +table1columndata = table1dataG + +table2dataG :: Num a => [(a, a)] +table2dataG = [ (1, 100) + , (3, 400) ] + +table2data :: [(Int, Int)] +table2data = table2dataG + +table2columndata :: [(Column O.PGInt4, Column O.PGInt4)] +table2columndata = table2dataG + +table3dataG :: Num a => [(a, a)] +table3dataG = [ (1, 50) ] + +table3data :: [(Int, Int)] +table3data = table3dataG + +table3columndata :: [(Column O.PGInt4, Column O.PGInt4)] +table3columndata = table3dataG + +table4dataG :: Num a => [(a, a)] +table4dataG = [ (1, 10) + , (2, 20) ] + +table4data :: [(Int, Int)] +table4data = table4dataG + +table4columndata :: [(Column O.PGInt4, Column O.PGInt4)] +table4columndata = table4dataG + +table6data :: [(String, String)] +table6data = [("xy", "a"), ("z", "a"), ("more text", "a")] + +table6columndata :: [(Column O.PGText, Column O.PGText)] +table6columndata = map (\(column1, column2) -> (O.pgString column1, O.pgString column2)) table6data + +-- We have to quote the table names here because upper case letters in +-- table names are treated as lower case unless the name is quoted! +-- +-- We have to issue multiple statements because sqlite-simple's +-- execute_ only executes the first in a ;-separated list, unlike +-- postgresql-simple +-- +-- http://hackage.haskell.org/package/sqlite-simple-0.4.9.0/docs/Database-SQLite-Simple.html#v:execute +dropAndCreateTable :: String -> (String, [String]) -> [PGS.Query] +dropAndCreateTable columnType (t, cols) = map String.fromString drop_ + where drop_ = [ "DROP TABLE IF EXISTS \"" ++ t ++ "\"" + , "CREATE TABLE \"" ++ t ++ "\"" + ++ " (" ++ commas cols ++ ")" ] + integer c = ("\"" ++ c ++ "\"" ++ " " ++ columnType) + commas = L.intercalate "," . map integer + +dropAndCreateTableInt :: (String, [String]) -> [PGS.Query] +dropAndCreateTableInt = dropAndCreateTable "integer" + +dropAndCreateTableText :: (String, [String]) -> [PGS.Query] +dropAndCreateTableText = dropAndCreateTable "text" + +-- We have to quote the table names here because upper case letters in +-- table names are treated as lower case unless the name is quoted! +-- +-- We have to issue multiple statements because sqlite-simple's +-- execute_ only executes the first in a ;-separated list, unlike +-- postgresql-simple +-- +-- http://hackage.haskell.org/package/sqlite-simple-0.4.9.0/docs/Database-SQLite-Simple.html#v:execute +dropAndCreateTableSerial :: (String, [String]) -> [PGS.Query] +dropAndCreateTableSerial (t, cols) = map String.fromString drop_ + where drop_ = [ "DROP TABLE IF EXISTS " ++ t + , "CREATE TABLE " ++ t + ++ " (" ++ commas cols ++ ")" ] + integer c = ("\"" ++ c ++ "\"" ++ " SERIAL") + commas = L.intercalate "," . map integer + +type Table_ = (String, [String]) + +-- This should ideally be derived from the table definition above +columns2 :: String -> Table_ +columns2 t = (t, ["column1", "column2"]) + +-- This should ideally be derived from the table definition above +tables :: [Table_] +tables = map columns2 ["table1", "TABLE2", "table3", "table4"] + ++ [("keywordtable", ["column", "where"])] + +serialTables :: [Table_] +serialTables = map columns2 ["table5"] + +dropAndCreateDB :: PGS.Connection -> IO () +dropAndCreateDB conn = do + mapM_ execute tables + executeTextTable + mapM_ executeSerial serialTables + where execute = mapM_ (PGS.execute_ conn) . dropAndCreateTableInt + executeTextTable = (mapM_ (PGS.execute_ conn) + . dropAndCreateTableText + . columns2) "table6" + executeSerial = mapM_ (PGS.execute_ conn) . dropAndCreateTableSerial + +type Test = PGS.Connection -> IO Bool + +testG :: D.Default O.QueryRunner wires haskells => + Query wires + -> ([haskells] -> b) + -> PGS.Connection + -> IO b +testG q p conn = do + result <- O.runQuery conn q + return (p result) + +testSelect :: Test +testSelect = testG table1Q + (\r -> L.sort table1data == L.sort r) + +testProduct :: Test +testProduct = testG query + (\r -> L.sort (A.liftA2 (,) table1data table2data) == L.sort r) + where query = table1Q &&& table2Q + +testRestrict :: Test +testRestrict = testG query + (\r -> filter ((== 1) . fst) (L.sort table1data) == L.sort r) + where query = proc () -> do + t <- table1Q -< () + O.restrict -< fst t .== 1 + Arr.returnA -< t + +testNum :: Test +testNum = testG query expected + where query :: Query (Column O.PGInt4) + query = proc () -> do + t <- table1Q -< () + Arr.returnA -< op t + expected = \r -> L.sort (map op table1data) == L.sort r + op :: Num a => (a, a) -> a + op (x, y) = abs (x - 5) * signum (x - 4) * (y * y + 1) + +testDiv :: Test +testDiv = testG query expected + where query :: Query (Column O.PGFloat8) + query = proc () -> do + t <- Arr.arr (O.doubleOfInt *** O.doubleOfInt) <<< table1Q -< () + Arr.returnA -< op t + expected r = L.sort (map (op . toDoubles) table1data) == L.sort r + op :: Fractional a => (a, a) -> a + -- Choosing 0.5 here as it should be exactly representable in + -- floating point + op (x, y) = y / x * 0.5 + toDoubles :: (Int, Int) -> (Double, Double) + toDoubles = fromIntegral *** fromIntegral + +-- TODO: need to implement and test case_ returning tuples +testCase :: Test +testCase = testG q (== expected) + 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 (O.distinct table1Q) + (\r -> L.sort (L.nub table1data) == L.sort r) + +-- FIXME: the unsafeCoerceColumn is currently needed because the type +-- changes required for aggregation are not currently dealt with by +-- Opaleye. +aggregateCoerceFIXME :: QueryArr (Column O.PGInt4) (Column O.PGInt8) +aggregateCoerceFIXME = Arr.arr aggregateCoerceFIXME' + +aggregateCoerceFIXME' :: Column a -> Column O.PGInt8 +aggregateCoerceFIXME' = O.unsafeCoerceColumn + +testAggregate :: Test +testAggregate = testG (Arr.second aggregateCoerceFIXME + <<< 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 = 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 (O.sum, O.count)) +{- +testStringArrayAggregate :: Test +testStringArrayAggregate = testG q expected + where q = O.aggregate (PP.p2 (O.arrayAgg, O.min)) table6Q + expected r = [(map fst table6data, minimum (map snd table6data))] == r +-} +testStringAggregate :: Test +testStringAggregate = testG q expected + where q = O.aggregate (PP.p2 ((O.stringAgg . O.pgString) "_", O.groupBy)) table6Q + expected r = [( + (foldl1 (\x y -> x ++ "_" ++ y) . map fst) table6data , + head (map snd table6data))] == r + +testOrderByG :: O.Order (Column O.PGInt4, Column O.PGInt4) + -> ((Int, Int) -> (Int, Int) -> Ordering) + -> Test +testOrderByG orderQ order = testG (O.orderBy orderQ table1Q) + (L.sortBy order table1data ==) + +testOrderBy :: Test +testOrderBy = testOrderByG (O.desc snd) + (flip (Ord.comparing snd)) + +testOrderBy2 :: Test +testOrderBy2 = testOrderByG (O.desc fst <> O.asc snd) + (flip (Ord.comparing fst) <> Ord.comparing snd) + +testOrderBySame :: Test +testOrderBySame = testOrderByG (O.desc fst <> O.asc fst) + (flip (Ord.comparing fst) <> Ord.comparing fst) + +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 = O.orderBy (O.desc snd) + order = L.sortBy (flip (Ord.comparing snd)) + +testLimit :: Test +testLimit = testLOG (O.limit 2) (take 2) + +testOffset :: Test +testOffset = testLOG (O.offset 2) (drop 2) + +testLimitOffset :: Test +testLimitOffset = testLOG (O.limit 2 . O.offset 2) (take 2 . drop 2) + +testOffsetLimit :: Test +testOffsetLimit = testLOG (O.offset 2 . O.limit 2) (drop 2 . take 2) + +testDistinctAndAggregate :: Test +testDistinctAndAggregate = testG q expected + where q = O.distinct table1Q + &&& (Arr.second aggregateCoerceFIXME + <<< 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 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 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 O.distinct [1 :: Int] + +testDoubleAggregate :: Test +testDoubleAggregate = testDoubleG (O.aggregate O.count) [1 :: Int64] + +testDoubleLeftJoin :: Test +testDoubleLeftJoin = testDoubleG lj [(1 :: Int, Just (1 :: Int))] + 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 O.PGInt4) -> Query (Column O.PGInt4) + v _ = O.values [1] + +testDoubleUnionAll :: Test +testDoubleUnionAll = testDoubleG u [1 :: Int, 1] + where u q = q `O.unionAll` q + +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) + where expected :: [((Int, Int), (Maybe Int, Maybe Int))] + expected = [ ((1, 100), (Just 1, Just 50)) + , ((1, 100), (Just 1, Just 50)) + , ((1, 200), (Just 1, Just 50)) + , ((2, 300), (Nothing, Nothing)) ] + +testLeftJoinNullable :: Test +testLeftJoinNullable = testG q (== expected) + 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) + + expected :: [((Int, Int), ((Maybe Int, Maybe Int), (Maybe Int, Maybe Int)))] + expected = [ ((1, 50), ((Just 1, Just 100), (Just 1, Just 50))) + , ((1, 50), ((Just 1, Just 100), (Just 1, Just 50))) + , ((1, 50), ((Just 1, Just 200), (Just 1, Just 50))) ] + +testThreeWayProduct :: Test +testThreeWayProduct = testG q (== expected) + where q = A.liftA3 (,,) table1Q table2Q table3Q + expected = A.liftA3 (,,) table1data table2data table3data + +testValues :: Test +testValues = testG (O.values values) (values' ==) + where values :: [(Column O.PGInt4, Column O.PGInt4)] + values = [ (1, 10) + , (2, 100) ] + values' :: [(Int, Int)] + values' = [ (1, 10) + , (2, 100) ] + +{- FIXME: does not yet work +testValuesDouble :: Test +testValuesDouble = testG (O.values values) (values' ==) + where values :: [(Column O.PGInt4, Column O.PGFloat8)] + values = [ (1, 10.0) + , (2, 100.0) ] + values' :: [(Int, Double)] + values' = [ (1, 10.0) + , (2, 100.0) ] +-} + +testValuesEmpty :: Test +testValuesEmpty = testG (O.values values) (values' ==) + where values :: [Column O.PGInt4] + values = [] + values' :: [Int] + values' = [] + +testUnionAll :: Test +testUnionAll = testG (table1Q `O.unionAll` table2Q) + (\r -> L.sort (table1data ++ table2data) == L.sort r) + +testTableFunctor :: Test +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 + _ <- O.runUpdate conn table4 update cond + result <- runQueryTable4 + + if result /= expected + then return False + else do + _ <- O.runDelete conn table4 condD + resultD <- runQueryTable4 + + if resultD /= expectedD + then return False + else return True +{- + else do + returned <- O.runInsertReturning conn table4 insertT returning + _ <- O.runInsertMany conn table4 insertTMany + resultI <- runQueryTable4 + + return ((resultI == expectedI) && (returned == expectedR)) +-} + where update (x, y) = (x + y, x - y) + cond (_, y) = y .> 15 + condD (x, _) = x .> 20 + expected :: [(Int, Int)] + expected = [ (1, 10) + , (22, -18)] + expectedD :: [(Int, Int)] + expectedD = [(1, 10)] + runQueryTable4 = O.runQuery conn (O.queryTable table4) + + insertT :: (Column O.PGInt4, Column O.PGInt4) + insertT = (1, 2) + + insertTMany :: [(Column O.PGInt4, Column O.PGInt4)] + insertTMany = [(20, 30), (40, 50)] + + expectedI :: [(Int, Int)] + expectedI = [(1, 10), (1, 2), (20, 30), (40, 50)] + returning (x, y) = x - y + expectedR :: [Int] + expectedR = [-1] + +testKeywordColNames :: Test +testKeywordColNames conn = do + let q :: IO [(Int, Int)] + q = O.runQuery conn (O.queryTable tableKeywordColNames) + _ <- q + return True + +testInsertSerial :: Test +testInsertSerial conn = do + _ <- O.runInsert conn table5 (Just 10, Just 20) + _ <- O.runInsert conn table5 (Just 30, Nothing) + _ <- O.runInsert conn table5 (Nothing, Nothing) + _ <- O.runInsert conn table5 (Nothing, Just 40) + + resultI <- O.runQuery conn (O.queryTable table5) + + return (resultI == expected) + + where expected :: [(Int, Int)] + expected = [ (10, 20) + , (30, 1) + , (1, 2) + , (2, 40) ] + +allTests :: [Test] +allTests = [testSelect, testProduct, testRestrict, testNum, testDiv, testCase, + testDistinct, testAggregate, testAggregateProfunctor, {-testStringAggregate,-} + testOrderBy, testOrderBy2, testOrderBySame, testLimit{- , testOffset, + testLimitOffset, testOffsetLimit -}, testDistinctAndAggregate, + testDoubleDistinct, testDoubleAggregate, testDoubleLeftJoin{-, + testDoubleValues -} , testDoubleUnionAll, + testLeftJoin, testLeftJoinNullable, testThreeWayProduct{-, testValues, + testValuesEmpty-}, testUnionAll, testTableFunctor, testUpdate, + testKeywordColNames{- , testInsertSerial-} + ] + +main :: IO () +main = do + conn <- PGS.open ":memory:" + + dropAndCreateDB conn + + let insert (writeable, columndata) = + mapM_ (O.runInsert conn writeable) columndata + + mapM_ insert [ (table1, table1columndata) + , (table2, table2columndata) + , (table3, table3columndata) + , (table4, table4columndata) ] + insert (table6, table6columndata) + + -- Need to run quickcheck after table data has been inserted + QuickCheck.run conn + + results <- mapM ($ conn) allTests + + print results + + let passed = and results + + putStrLn (if passed then "All passed" else "Failure") + Exit.exitWith (if passed then Exit.ExitSuccess + else Exit.ExitFailure 1) diff --git a/opaleye-sqlite.cabal b/opaleye-sqlite.cabal new file mode 100644 --- /dev/null +++ b/opaleye-sqlite.cabal @@ -0,0 +1,120 @@ +name: opaleye-sqlite +copyright: Copyright (c) 2014-2015 Purely Agile Limited +version: 0.0.0.0 +synopsis: An SQL-generating DSL targeting SQLite +description: An SQL-generating DSL targeting SQLite. Allows + SQLite queries to be written within Haskell in a + typesafe and composable fashion. +homepage: https://github.com/tomjaguarpaw/haskell-opaleye +bug-reports: https://github.com/tomjaguarpaw/haskell-opaleye/issues +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 +tested-with: GHC==7.10.1, GHC==7.8.4, GHC==7.6.3 + +source-repository head + type: git + location: https://github.com/tomjaguarpaw/haskell-opaleye.git + +library + hs-source-dirs: src + build-depends: + base >= 4 && < 5 + , base16-bytestring >= 0.1.1.6 && < 0.2 + , case-insensitive >= 1.2 && < 1.3 + , bytestring >= 0.10 && < 0.11 + , contravariant >= 1.2 && < 1.4 + , direct-sqlite >= 2.3.13 && < 2.4 + , pretty >= 1.1.1.0 && < 1.2 + , product-profunctors >= 0.6.2 && < 0.7 + , profunctors >= 4.0 && < 5.2 + , semigroups >= 0.13 && < 0.17 + , sqlite-simple + , text >= 0.11 && < 1.3 + , transformers >= 0.3 && < 0.5 + , time >= 1.4 && < 1.6 + , time-locale-compat >= 0.1 && < 0.2 + , uuid >= 1.3 && < 1.4 + , void >= 0.4 && < 0.8 + exposed-modules: Opaleye.SQLite, + Opaleye.SQLite.Aggregate, + Opaleye.SQLite.Binary, + Opaleye.SQLite.Column, + Opaleye.SQLite.Distinct, + Opaleye.SQLite.Join, + Opaleye.SQLite.Manipulation, + Opaleye.SQLite.Operators, + Opaleye.SQLite.Order, + Opaleye.SQLite.PGTypes, + Opaleye.SQLite.QueryArr, + Opaleye.SQLite.RunQuery, + Opaleye.SQLite.Sql, + Opaleye.SQLite.SqlTypes, + Opaleye.SQLite.Table, + Opaleye.SQLite.Values, + Opaleye.SQLite.Internal.Aggregate, + Opaleye.SQLite.Internal.Binary, + Opaleye.SQLite.Internal.Column, + Opaleye.SQLite.Internal.Distinct, + Opaleye.SQLite.Internal.Helpers, + Opaleye.SQLite.Internal.Join, + Opaleye.SQLite.Internal.Order, + Opaleye.SQLite.Internal.Optimize, + Opaleye.SQLite.Internal.PackMap, + Opaleye.SQLite.Internal.PGTypes, + Opaleye.SQLite.Internal.PrimQuery, + Opaleye.SQLite.Internal.Print, + Opaleye.SQLite.Internal.QueryArr, + Opaleye.SQLite.Internal.RunQuery, + Opaleye.SQLite.Internal.Sql, + Opaleye.SQLite.Internal.Table, + Opaleye.SQLite.Internal.TableMaker, + Opaleye.SQLite.Internal.Tag, + Opaleye.SQLite.Internal.Unpackspec, + Opaleye.SQLite.Internal.Values + Opaleye.SQLite.Internal.HaskellDB.PrimQuery, + Opaleye.SQLite.Internal.HaskellDB.Sql, + Opaleye.SQLite.Internal.HaskellDB.Sql.Default, + Opaleye.SQLite.Internal.HaskellDB.Sql.Generate, + Opaleye.SQLite.Internal.HaskellDB.Sql.Print + ghc-options: -Wall + +test-suite test + type: exitcode-stdio-1.0 + main-is: Test.hs + other-modules: QuickCheck + hs-source-dirs: Test + build-depends: + base >= 4 && < 5, + containers, + contravariant, + profunctors, + product-profunctors, + QuickCheck, + semigroups, + sqlite-simple, + opaleye-sqlite + ghc-options: -Wall + +test-suite tutorial + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: TutorialAdvanced, + TutorialBasic, + TutorialManipulation, + DefaultExplanation + hs-source-dirs: Doc/Tutorial + build-depends: + base >= 4 && < 5, + profunctors, + product-profunctors >= 0.6, + sqlite-simple, + time, + opaleye-sqlite + ghc-options: -Wall diff --git a/src/Opaleye/SQLite.hs b/src/Opaleye/SQLite.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/SQLite.hs @@ -0,0 +1,30 @@ +module Opaleye.SQLite ( module Opaleye.SQLite.Aggregate + , module Opaleye.SQLite.Binary + , module Opaleye.SQLite.Column + , module Opaleye.SQLite.Distinct + , module Opaleye.SQLite.Join + , module Opaleye.SQLite.Manipulation + , module Opaleye.SQLite.Operators + , module Opaleye.SQLite.Order + , module Opaleye.SQLite.PGTypes + , module Opaleye.SQLite.QueryArr + , module Opaleye.SQLite.RunQuery + , module Opaleye.SQLite.Sql + , module Opaleye.SQLite.Table + , module Opaleye.SQLite.Values + ) where + +import Opaleye.SQLite.Aggregate +import Opaleye.SQLite.Binary +import Opaleye.SQLite.Column +import Opaleye.SQLite.Distinct +import Opaleye.SQLite.Join +import Opaleye.SQLite.Manipulation +import Opaleye.SQLite.Operators +import Opaleye.SQLite.Order +import Opaleye.SQLite.PGTypes +import Opaleye.SQLite.QueryArr +import Opaleye.SQLite.RunQuery +import Opaleye.SQLite.Sql +import Opaleye.SQLite.Table +import Opaleye.SQLite.Values diff --git a/src/Opaleye/SQLite/Aggregate.hs b/src/Opaleye/SQLite/Aggregate.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/SQLite/Aggregate.hs @@ -0,0 +1,61 @@ +-- | Perform aggregations on query results. +module Opaleye.SQLite.Aggregate (module Opaleye.SQLite.Aggregate, Aggregator) where + +import qualified Opaleye.SQLite.Internal.Aggregate as A +import Opaleye.SQLite.Internal.Aggregate (Aggregator) +import qualified Opaleye.SQLite.Internal.Column as IC +import Opaleye.SQLite.QueryArr (Query) +import qualified Opaleye.SQLite.Internal.QueryArr as Q +import qualified Opaleye.SQLite.Column as C +import qualified Opaleye.SQLite.Order as Ord +import qualified Opaleye.SQLite.PGTypes as T +import qualified Opaleye.SQLite.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 :: Ord.PGOrd a => Aggregator (C.Column a) (C.Column a) +max = A.makeAggr HPQ.AggrMax + +-- | Maximum of a group +min :: Ord.PGOrd a => 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 + +arrayAgg :: Aggregator (C.Column a) (C.Column (T.PGArray a)) +arrayAgg = A.makeAggr HPQ.AggrArr + +stringAgg :: C.Column T.PGText -> Aggregator (C.Column T.PGText) (C.Column T.PGText) +stringAgg = A.makeAggr' . Just . HPQ.AggrStringAggr . IC.unColumn diff --git a/src/Opaleye/SQLite/Binary.hs b/src/Opaleye/SQLite/Binary.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/SQLite/Binary.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts #-} + +module Opaleye.SQLite.Binary where + +import Opaleye.SQLite.QueryArr (Query) +import qualified Opaleye.SQLite.Internal.QueryArr as Q +import qualified Opaleye.SQLite.Internal.Binary as B +import qualified Opaleye.SQLite.Internal.Tag as T +import qualified Opaleye.SQLite.Internal.PrimQuery as PQ +import qualified Opaleye.SQLite.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/SQLite/Column.hs b/src/Opaleye/SQLite/Column.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/SQLite/Column.hs @@ -0,0 +1,48 @@ +module Opaleye.SQLite.Column (module Opaleye.SQLite.Column, + Column, + Nullable, + unsafeCoerce, + unsafeCoerceColumn) where + +import Opaleye.SQLite.Internal.Column (Column, Nullable, unsafeCoerce, unsafeCoerceColumn) +import qualified Opaleye.SQLite.Internal.Column as C +import qualified Opaleye.SQLite.Internal.HaskellDB.PrimQuery as HPQ +import qualified Opaleye.SQLite.PGTypes as T +import Prelude hiding (null) + +-- | A NULL of any type +null :: Column (Nullable a) +null = 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 (unsafeCoerceColumn 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 = unsafeCoerceColumn + +-- | 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 -> Column a -> Column b +unsafeCast = C.unsafeCast diff --git a/src/Opaleye/SQLite/Distinct.hs b/src/Opaleye/SQLite/Distinct.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/SQLite/Distinct.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Opaleye.SQLite.Distinct (module Opaleye.SQLite.Distinct, distinctExplicit) + where + +import Opaleye.SQLite.QueryArr (Query) +import Opaleye.SQLite.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/SQLite/Internal/Aggregate.hs b/src/Opaleye/SQLite/Internal/Aggregate.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/SQLite/Internal/Aggregate.hs @@ -0,0 +1,71 @@ +module Opaleye.SQLite.Internal.Aggregate where + +import Control.Applicative (Applicative, pure, (<*>)) + +import qualified Data.Profunctor as P +import qualified Data.Profunctor.Product as PP + +import qualified Opaleye.SQLite.Internal.PackMap as PM +import qualified Opaleye.SQLite.Internal.PrimQuery as PQ +import qualified Opaleye.SQLite.Internal.Tag as T +import qualified Opaleye.SQLite.Internal.Column as C + +import qualified Opaleye.SQLite.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. + +An 'Aggregator' corresponds closely to a 'Control.Foldl.Fold' from the +@foldl@ package. Whereas an 'Aggregator' @a@ @b@ takes each group of +type @a@ to a single row of type @b@, a 'Control.Foldl.Fold' @a@ @b@ +takes a list of @a@ and returns a single row of type @b@. +-} +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.traversePM 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 + +instance PP.SumProfunctor Aggregator where + Aggregator x1 +++! Aggregator x2 = Aggregator (x1 PP.+++! x2) + +-- } diff --git a/src/Opaleye/SQLite/Internal/Binary.hs b/src/Opaleye/SQLite/Internal/Binary.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/SQLite/Internal/Binary.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts #-} + +module Opaleye.SQLite.Internal.Binary where + +import Opaleye.SQLite.Internal.Column (Column(Column)) +import qualified Opaleye.SQLite.Internal.Tag as T +import qualified Opaleye.SQLite.Internal.PackMap as PM + +import qualified Opaleye.SQLite.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" + +newtype 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.traversePM b + +binaryspecColumn :: Binaryspec (Column a) (Column a) +binaryspecColumn = Binaryspec (PM.PackMap (\f (Column e, Column e') + -> fmap Column (f (e, e')))) + +instance Default Binaryspec (Column a) (Column a) where + def = binaryspecColumn + +-- { + +-- 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/SQLite/Internal/Column.hs b/src/Opaleye/SQLite/Internal/Column.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/SQLite/Internal/Column.hs @@ -0,0 +1,69 @@ +module Opaleye.SQLite.Internal.Column where + +import qualified Opaleye.SQLite.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 + +{-# DEPRECATED unsafeCoerce "Use unsafeCoerceColumn instead" #-} +unsafeCoerce :: Column a -> Column b +unsafeCoerce = unsafeCoerceColumn + +unsafeCoerceColumn :: Column a -> Column b +unsafeCoerceColumn (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 + +unsafeCast :: String -> Column a -> Column b +unsafeCast = mapColumn . HPQ.CastExpr + where + mapColumn :: (HPQ.PrimExpr -> HPQ.PrimExpr) -> Column c -> Column a + mapColumn primExpr = Column . primExpr . unColumn diff --git a/src/Opaleye/SQLite/Internal/Distinct.hs b/src/Opaleye/SQLite/Internal/Distinct.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/SQLite/Internal/Distinct.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE MultiParamTypeClasses #-} + +module Opaleye.SQLite.Internal.Distinct where + +import Opaleye.SQLite.QueryArr (Query) +import Opaleye.SQLite.Column (Column) +import Opaleye.SQLite.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 + +newtype 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 + +instance PP.SumProfunctor Distinctspec where + Distinctspec x1 +++! Distinctspec x2 = Distinctspec (x1 PP.+++! x2) + +-- } diff --git a/src/Opaleye/SQLite/Internal/HaskellDB/PrimQuery.hs b/src/Opaleye/SQLite/Internal/HaskellDB/PrimQuery.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/SQLite/Internal/HaskellDB/PrimQuery.hs @@ -0,0 +1,85 @@ +-- Copyright : Daan Leijen (c) 1999, daan@cs.uu.nl +-- HWT Group (c) 2003, haskelldb-users@lists.sourceforge.net +-- License : BSD-style + +module Opaleye.SQLite.Internal.HaskellDB.PrimQuery where + +import qualified Opaleye.SQLite.Internal.Tag as T +import Data.ByteString (ByteString) + +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. + | DefaultInsertExpr -- Indicate that we want to insert the + -- default value into a column. + -- TODO: I'm not sure this belongs + -- here. Perhaps a special type is + -- needed for insert expressions. + deriving (Read,Show) + +data Literal = NullLit + | DefaultLit -- ^ represents a default value + | BoolLit Bool + | StringLit String + | ByteStringLit ByteString + | 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 | AggrArr | AggrStringAggr PrimExpr + | AggrOther String + deriving (Show,Read) + +data OrderExpr = OrderExpr OrderOp PrimExpr + deriving (Show) + +data OrderNulls = NullsFirst | NullsLast + deriving Show + +data OrderDirection = OpAsc | OpDesc + deriving Show + +data OrderOp = OrderOp { orderDirection :: OrderDirection + , orderNulls :: OrderNulls } + deriving (Show) diff --git a/src/Opaleye/SQLite/Internal/HaskellDB/Sql.hs b/src/Opaleye/SQLite/Internal/HaskellDB/Sql.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/SQLite/Internal/HaskellDB/Sql.hs @@ -0,0 +1,55 @@ +-- Copyright : Daan Leijen (c) 1999, daan@cs.uu.nl +-- HWT Group (c) 2003, haskelldb-users@lists.sourceforge.net +-- License : BSD-style + +module Opaleye.SQLite.Internal.HaskellDB.Sql where + + +import qualified Data.List.NonEmpty as NEL + +----------------------------------------------------------- +-- * SQL data type +----------------------------------------------------------- + +newtype SqlTable = SqlTable String deriving Show + +newtype SqlColumn = SqlColumn String deriving Show + +-- | A valid SQL name for a parameter. +type SqlName = String + +data SqlOrderNulls = SqlNullsFirst | SqlNullsLast + deriving Show + +data SqlOrderDirection = SqlAsc | SqlDesc + deriving Show + +data SqlOrder = SqlOrder { sqlOrderDirection :: SqlOrderDirection + , sqlOrderNulls :: SqlOrderNulls } + 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 + | DefaultSqlExpr + 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] (NEL.NonEmpty [SqlExpr]) diff --git a/src/Opaleye/SQLite/Internal/HaskellDB/Sql/Default.hs b/src/Opaleye/SQLite/Internal/HaskellDB/Sql/Default.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/SQLite/Internal/HaskellDB/Sql/Default.hs @@ -0,0 +1,230 @@ +-- Copyright : Daan Leijen (c) 1999, daan@cs.uu.nl +-- HWT Group (c) 2003, haskelldb-users@lists.sourceforge.net +-- License : BSD-style + +module Opaleye.SQLite.Internal.HaskellDB.Sql.Default where + +import Opaleye.SQLite.Internal.HaskellDB.PrimQuery +import qualified Opaleye.SQLite.Internal.HaskellDB.PrimQuery as PQ +import Opaleye.SQLite.Internal.HaskellDB.Sql +import Opaleye.SQLite.Internal.HaskellDB.Sql.Generate +import qualified Opaleye.SQLite.Internal.HaskellDB.Sql as Sql +import Opaleye.SQLite.Internal.Tag (tagWith) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString.Base16 as Base16 +import qualified Data.List.NonEmpty as NEL + +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, Sql.SqlOrder { sqlOrderDirection = o' + , sqlOrderNulls = orderNulls' }) + where o' = case PQ.orderDirection o of + PQ.OpAsc -> Sql.SqlAsc + PQ.OpDesc -> Sql.SqlDesc + orderNulls' = case PQ.orderNulls o of + PQ.NullsFirst -> Sql.SqlNullsFirst + PQ.NullsLast -> Sql.SqlNullsLast + + +toSqlColumn :: Attribute -> SqlColumn +toSqlColumn attr = SqlColumn attr + +toSqlAssoc :: SqlGenerator -> Assoc -> [(SqlColumn,SqlExpr)] +toSqlAssoc gen = map (\(attr,expr) -> (toSqlColumn 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 (SqlTable name) (toSqlAssoc gen assigns) (map (sqlExpr gen) criteria) + + +defaultSqlInsert :: SqlGenerator + -> TableName + -> [Attribute] + -> NEL.NonEmpty [PrimExpr] + -> SqlInsert +defaultSqlInsert gen name attrs exprs = + SqlInsert (SqlTable name) (map toSqlColumn attrs) ((fmap . map) (sqlExpr gen) exprs) + +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 (SqlTable 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' + -- TODO: The current arrangement whereby the delimeter parameter + -- of string_agg is in the AggrStringAggr constructor, but the + -- parameter being aggregated is not, seems unsatisfactory + -- because it leads to a non-uniformity of treatment, as seen + -- below. Perhaps we should have just `AggrExpr AggrOp` and + -- always put the `PrimExpr` in the `AggrOp`. + AggrExpr op e -> let op' = showAggrOp op + e' = sqlExpr gen e + moreAggrFunParams = case op of + AggrStringAggr primE -> [sqlExpr gen primE] + _ -> [] + in AggrFunSqlExpr op' (e' : moreAggrFunParams) + 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) + DefaultInsertExpr -> DefaultSqlExpr + +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 = ("ABS", 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 AggrArr = "ARRAY_AGG" +showAggrOp (AggrStringAggr _) = "STRING_AGG" +showAggrOp (AggrOther s) = s + + +defaultSqlLiteral :: SqlGenerator -> Literal -> String +defaultSqlLiteral _ l = + case l of + NullLit -> "NULL" + DefaultLit -> "DEFAULT" + BoolLit True -> "1" + BoolLit False -> "0" + ByteStringLit s + -> binQuote s + StringLit s -> quote s + IntegerLit i -> show i + DoubleLit d -> show d + OtherLit o -> o + + +defaultSqlQuote :: SqlGenerator -> String -> String +defaultSqlQuote _ s = quote s + +quote :: String -> String +quote s = "'" ++ concatMap escape s ++ "'" + +-- | Escape characters that need escaping +-- FIXME: Escaping control characters probably doesn't work in SQLite +-- Need more tests +escape :: Char -> String +escape '\NUL' = "\\0" +escape '\'' = "''" +escape '"' = "\\\"" +escape '\b' = "\\b" +escape '\n' = "\\n" +escape '\r' = "\\r" +escape '\t' = "\\t" +escape '\\' = "\\\\" +escape c = [c] + + +-- | Quote binary literals using Postgresql's hex format. +binQuote :: ByteString -> String +binQuote s = "E'\\\\x" ++ BS8.unpack (Base16.encode s) ++ "'" diff --git a/src/Opaleye/SQLite/Internal/HaskellDB/Sql/Generate.hs b/src/Opaleye/SQLite/Internal/HaskellDB/Sql/Generate.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/SQLite/Internal/HaskellDB/Sql/Generate.hs @@ -0,0 +1,22 @@ +-- Copyright : Daan Leijen (c) 1999, daan@cs.uu.nl +-- HWT Group (c) 2003, haskelldb-users@lists.sourceforge.net +-- License : BSD-style + +module Opaleye.SQLite.Internal.HaskellDB.Sql.Generate (SqlGenerator(..)) where + +import Opaleye.SQLite.Internal.HaskellDB.PrimQuery +import Opaleye.SQLite.Internal.HaskellDB.Sql + +import qualified Data.List.NonEmpty as NEL + +data SqlGenerator = SqlGenerator + { + sqlUpdate :: TableName -> [PrimExpr] -> Assoc -> SqlUpdate, + sqlDelete :: TableName -> [PrimExpr] -> SqlDelete, + sqlInsert :: TableName -> [Attribute] -> NEL.NonEmpty [PrimExpr] -> 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/SQLite/Internal/HaskellDB/Sql/Print.hs b/src/Opaleye/SQLite/Internal/HaskellDB/Sql/Print.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/SQLite/Internal/HaskellDB/Sql/Print.hs @@ -0,0 +1,138 @@ +-- Copyright : Daan Leijen (c) 1999, daan@cs.uu.nl +-- HWT Group (c) 2003, haskelldb-users@lists.sourceforge.net +-- License : BSD-style + +module Opaleye.SQLite.Internal.HaskellDB.Sql.Print ( + ppUpdate, + ppDelete, + ppInsert, + ppSqlExpr, + ppWhere, + ppGroupBy, + ppOrderBy, + ppTable, + ppAs, + commaV, + commaH + ) where + +import Opaleye.SQLite.Internal.HaskellDB.Sql (SqlColumn(..), SqlDelete(..), + SqlExpr(..), SqlOrder(..), SqlInsert(..), + SqlUpdate(..), SqlTable(..)) +import qualified Opaleye.SQLite.Internal.HaskellDB.Sql as Sql + +import Data.List (intersperse) +import qualified Data.List.NonEmpty as NEL +import Text.PrettyPrint.HughesPJ (Doc, (<+>), ($$), (<>), comma, doubleQuotes, + 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 + -- Silliness to avoid "ORDER BY 1" etc. meaning order by the first column + -- Any identity function will do + -- nameOrExpr expr = parens (ppSqlExpr expr) + -- SQLite requires COALESCE to have at least two arguments. + nameOrExpr expr = text "COALESCE" <+> parens (commaH ppSqlExpr [expr, expr]) + +ppOrderBy :: [(SqlExpr,SqlOrder)] -> Doc +ppOrderBy [] = empty +ppOrderBy ord = text "ORDER BY" <+> commaV ppOrd ord + where + -- Silliness to avoid "ORDER BY 1" etc. meaning order by the first column + -- Any identity function will do + -- ppOrd (e,o) = ppSqlExpr e <+> ppSqlDirection o <+> ppSqlNulls o + ppOrd (e,o) = text "COALESCE" + <+> parens (commaH ppSqlExpr [e, e]) + <+> ppSqlDirection o + <+> ppSqlNulls o + +ppSqlDirection :: Sql.SqlOrder -> Doc +ppSqlDirection x = text $ case Sql.sqlOrderDirection x of + Sql.SqlAsc -> "ASC" + Sql.SqlDesc -> "DESC" + +-- FIXME: We haven't implemented NULL ordering properly +ppSqlNulls :: Sql.SqlOrder -> Doc +ppSqlNulls x = empty +--ppSqlNulls x = text $ case Sql.sqlOrderNulls x of +-- Sql.SqlNullsFirst -> "NULLS FIRST" +-- Sql.SqlNullsLast -> "NULLS LAST" + +ppAs :: String -> Doc -> Doc +ppAs alias expr | null alias = expr + | otherwise = expr <+> hsep [text "as", doubleQuotes (text alias)] + + +ppUpdate :: SqlUpdate -> Doc +ppUpdate (SqlUpdate table assigns criteria) + = text "UPDATE" <+> ppTable table + $$ text "SET" <+> commaV ppAssign assigns + $$ ppWhere criteria + where + ppAssign (c,e) = ppColumn c <+> equals <+> ppSqlExpr e + + +ppDelete :: SqlDelete -> Doc +ppDelete (SqlDelete table criteria) = + text "DELETE FROM" <+> ppTable table $$ ppWhere criteria + + +ppInsert :: SqlInsert -> Doc +ppInsert (SqlInsert table names values) + = text "INSERT INTO" <+> ppTable table + <+> parens (commaV ppColumn names) + $$ text "VALUES" <+> commaV (\v -> parens (commaV ppSqlExpr v)) + (NEL.toList values) + +-- If we wanted to make the SQL slightly more readable this would be +-- one easy place to do it. Currently we wrap all column references +-- in double quotes in case they are keywords. However, we should be +-- sure that any column names we generate ourselves are not keywords, +-- so we only need to double quote base table column names. +ppColumn :: SqlColumn -> Doc +ppColumn (SqlColumn s) = doubleQuotes (text s) + +-- Postgres treats upper case letters in table names as lower case, +-- unless the name is quoted! +ppTable :: SqlTable -> Doc +ppTable (SqlTable s) = doubleQuotes (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) + DefaultSqlExpr -> text "DEFAULT" + +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/SQLite/Internal/Helpers.hs b/src/Opaleye/SQLite/Internal/Helpers.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/SQLite/Internal/Helpers.hs @@ -0,0 +1,21 @@ +module Opaleye.SQLite.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) + +infixr 8 .::. + +(.::.) :: (r -> z) -> (a -> b -> c -> d -> e -> r) -> a -> b -> c -> d -> e -> z +(.::.) f g a b c d e = f (g a b c d e) diff --git a/src/Opaleye/SQLite/Internal/Join.hs b/src/Opaleye/SQLite/Internal/Join.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/SQLite/Internal/Join.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-} + +module Opaleye.SQLite.Internal.Join where + +import qualified Opaleye.SQLite.Internal.Tag as T +import qualified Opaleye.SQLite.Internal.PackMap as PM +import Opaleye.SQLite.Internal.Column (Column, Nullable) +import qualified Opaleye.SQLite.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.SQLite.Internal.HaskellDB.PrimQuery as HPQ + +newtype 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.unsafeCoerceColumn + +instance D.Default NullMaker (Column (Nullable a)) (Column (Nullable a)) where + def = NullMaker C.unsafeCoerceColumn + +-- { 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/SQLite/Internal/Optimize.hs b/src/Opaleye/SQLite/Internal/Optimize.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/SQLite/Internal/Optimize.hs @@ -0,0 +1,31 @@ +module Opaleye.SQLite.Internal.Optimize where + +import Prelude hiding (product) + +import qualified Opaleye.SQLite.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/SQLite/Internal/Order.hs b/src/Opaleye/SQLite/Internal/Order.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/SQLite/Internal/Order.hs @@ -0,0 +1,57 @@ +module Opaleye.SQLite.Internal.Order where + +import qualified Opaleye.SQLite.Column as C +import qualified Opaleye.SQLite.Internal.Column as IC +import qualified Opaleye.SQLite.Internal.Tag as T +import qualified Opaleye.SQLite.Internal.PrimQuery as PQ + +import qualified Opaleye.SQLite.Internal.HaskellDB.PrimQuery as HPQ +import qualified Data.Functor.Contravariant as C +import qualified Data.Functor.Contravariant.Divisible as Divisible +import qualified Data.Profunctor as P +import qualified Data.Monoid as M +import qualified Data.Void as Void + +{-| +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. +-} + +-- Like the (columns -> RowParser haskells) field of QueryRunner this +-- type is "too big". We never actually look at the 'a' (in the +-- QueryRunner case the 'colums') except to check the "structure". +-- This is so we can support a SumProfunctor instance. +newtype Order a = Order (a -> [(HPQ.OrderOp, HPQ.PrimExpr)]) + +instance C.Contravariant Order where + contramap f (Order g) = Order (P.lmap f g) + +instance M.Monoid (Order a) where + mempty = Order M.mempty + Order o `mappend` Order o' = Order (o `M.mappend` o') + +instance Divisible.Divisible Order where + divide f o o' = M.mappend (C.contramap (fst . f) o) + (C.contramap (snd . f) o') + conquer = M.mempty + +instance Divisible.Decidable Order where + lose f = C.contramap f (Order Void.absurd) + choose f (Order o) (Order o') = C.contramap f (Order (either o o')) + +order :: HPQ.OrderOp -> (a -> C.Column b) -> Order a +order op f = Order (fmap (\column -> [(op, IC.unColumn column)]) f) + +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 (uncurry HPQ.OrderExpr) (sos columns) + +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/SQLite/Internal/PGTypes.hs b/src/Opaleye/SQLite/Internal/PGTypes.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/SQLite/Internal/PGTypes.hs @@ -0,0 +1,32 @@ +module Opaleye.SQLite.Internal.PGTypes where + +import Opaleye.SQLite.Internal.Column (Column(Column)) +import qualified Opaleye.SQLite.Internal.HaskellDB.PrimQuery as HPQ + +import qualified Data.Text as SText +import qualified Data.Text.Encoding as STextEncoding +import qualified Data.Text.Lazy as LText +import qualified Data.Text.Lazy.Encoding as LTextEncoding +import qualified Data.ByteString as SByteString +import qualified Data.ByteString.Lazy as LByteString +import qualified Data.Time as Time +import qualified Data.Time.Locale.Compat as Locale + +-- FIXME: SQLite requires temporal types to have the type "TEXT" which +-- may cause problems elsewhere. +unsafePgFormatTime :: Time.FormatTime t => HPQ.Name -> String -> t -> Column c +unsafePgFormatTime typeName formatString = castToType "TEXT" . format + where format = Time.formatTime Locale.defaultTimeLocale formatString + +literalColumn :: HPQ.Literal -> Column a +literalColumn = Column . HPQ.ConstExpr + +castToType :: HPQ.Name -> String -> Column c +castToType typeName = + Column . HPQ.CastExpr typeName . HPQ.ConstExpr . HPQ.OtherLit + +strictDecodeUtf8 :: SByteString.ByteString -> String +strictDecodeUtf8 = SText.unpack . STextEncoding.decodeUtf8 + +lazyDecodeUtf8 :: LByteString.ByteString -> String +lazyDecodeUtf8 = LText.unpack . LTextEncoding.decodeUtf8 diff --git a/src/Opaleye/SQLite/Internal/PackMap.hs b/src/Opaleye/SQLite/Internal/PackMap.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/SQLite/Internal/PackMap.hs @@ -0,0 +1,142 @@ +{-# LANGUAGE Rank2Types #-} + +module Opaleye.SQLite.Internal.PackMap where + +import qualified Opaleye.SQLite.Internal.Tag as T + +import qualified Opaleye.SQLite.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. + +-- | A 'PackMap' @a@ @b@ @s@ @t@ encodes how an @s@ contains an +-- updatable sequence of @a@ inside it. Each @a@ in the sequence can +-- be updated to a @b@ (and the @s@ changes to a @t@ to reflect this +-- change of type). +-- +-- 'PackMap' is just like a @Traversal@ from the lens package. +-- 'PackMap' has a different order of arguments to @Traversal@ because +-- it typically needs to be made a 'Profunctor' (and indeed +-- 'ProductProfunctor') in @s@ and @t@. It is unclear at this point +-- whether we want the same @Traversal@ laws to hold or not. Our use +-- cases may be much more general. +data PackMap a b s t = PackMap (Applicative f => + (a -> f b) -> s -> f t) + +-- | Replaces the targeted occurences of @a@ in @s@ with @b@ (changing +-- the @s@ to a @t@ in the process). This can be done via an +-- 'Applicative' action. +-- +-- 'traversePM' is just like @traverse@ from the @lens@ package. +-- 'traversePM' used to be called @packmap@. +traversePM :: Applicative f => PackMap a b s t -> (a -> f b) -> s -> f t +traversePM (PackMap f) = f + +-- | Modify the targeted occurrences of @a@ in @s@ with @b@ (changing +-- the @s@ to a @t@ in the process). +-- +-- 'overPM' is just like @over@ from the @lens@ pacakge. +overPM :: PackMap a b s t -> (a -> b) -> s -> t +overPM p f = I.runIdentity . traversePM 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 + +-- | Make a fresh name for an input value (the variable @primExpr@ +-- type is typically actually a 'HPQ.PrimExpr') based on the supplied +-- function and the unique 'T.Tag' that is used as part of our +-- @QueryArr@. +-- +-- Add the fresh name and the input value it refers to to the list in +-- the state parameter. +extractAttrPE :: (primExpr -> String -> String) -> T.Tag -> primExpr + -> PM [(HPQ.Symbol, primExpr)] HPQ.PrimExpr +extractAttrPE mkName t pe = do + i <- new + let s = HPQ.Symbol (mkName pe i) t + write (s, pe) + return (HPQ.AttrExpr s) + +-- | As 'extractAttrPE' but ignores the 'primExpr' when making the +-- fresh column name and just uses the supplied 'String' and 'T.Tag'. +extractAttr :: String -> T.Tag -> primExpr + -> PM [(HPQ.Symbol, primExpr)] HPQ.PrimExpr +extractAttr s = extractAttrPE (const (s ++)) + +-- } + +eitherFunction :: Functor f + => (a -> f b) + -> (a' -> f b') + -> Either a a' + -> f (Either b b') +eitherFunction f g = fmap (either (fmap Left) (fmap Right)) (f PP.+++! g) + +-- { + +-- 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 + +instance PP.SumProfunctor (PackMap a b) where + f +++! g = (PackMap (\x -> eitherFunction (f' x) (g' x))) + where PackMap f' = f + PackMap g' = g + +-- } diff --git a/src/Opaleye/SQLite/Internal/PrimQuery.hs b/src/Opaleye/SQLite/Internal/PrimQuery.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/SQLite/Internal/PrimQuery.hs @@ -0,0 +1,65 @@ +module Opaleye.SQLite.Internal.PrimQuery where + +import Prelude hiding (product) + +import qualified Data.List.NonEmpty as NEL +import qualified Opaleye.SQLite.Internal.HaskellDB.PrimQuery as HPQ +import Opaleye.SQLite.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 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 -> 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 cond q1 q2 -> join j 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/SQLite/Internal/Print.hs b/src/Opaleye/SQLite/Internal/Print.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/SQLite/Internal/Print.hs @@ -0,0 +1,122 @@ +module Opaleye.SQLite.Internal.Print where + +import Prelude hiding (product) + +import qualified Opaleye.SQLite.Internal.Sql as Sql +import Opaleye.SQLite.Internal.Sql (Select(SelectFrom, Table, + SelectJoin, + SelectValues, + SelectBinary), + From, Join, Values, Binary) + +import qualified Opaleye.SQLite.Internal.HaskellDB.Sql as HSql +import qualified Opaleye.SQLite.Internal.HaskellDB.Sql.Print as HPrint + +import Text.PrettyPrint.HughesPJ (Doc, ($$), (<+>), text, empty, + parens) +import qualified Data.List.NonEmpty as NEL + +type TableAlias = String + +ppSql :: Select -> Doc +ppSql (SelectFrom s) = ppSelectFrom s +ppSql (Table table) = HPrint.ppTable table +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 *" + $$ 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 :: Sql.SelectAttrs -> Doc +ppAttrs Sql.Star = text "*" +ppAttrs (Sql.SelectAttrs xs) = (HPrint.commaV nameAs . NEL.toList) 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 -> (TableAlias, Select) +tableAlias i select = ("T" ++ show i, select) + +-- TODO: duplication with ppSql +ppTable :: (TableAlias, Select) -> Doc +ppTable (alias, select) = case select of + Table table -> HPrint.ppAs alias (HPrint.ppTable table) + 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 :: Maybe (NEL.NonEmpty HSql.SqlExpr) -> Doc +ppGroupBy Nothing = empty +ppGroupBy (Just xs) = HPrint.ppGroupBy (NEL.toList 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 + +ppUpdateReturning :: Sql.Returning HSql.SqlUpdate -> Doc +ppUpdateReturning (Sql.Returning update returnExprs) = + HPrint.ppUpdate update + $$ text "RETURNING" + <+> HPrint.commaV HPrint.ppSqlExpr returnExprs diff --git a/src/Opaleye/SQLite/Internal/QueryArr.hs b/src/Opaleye/SQLite/Internal/QueryArr.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/SQLite/Internal/QueryArr.hs @@ -0,0 +1,68 @@ +module Opaleye.SQLite.Internal.QueryArr where + +import Prelude hiding (id) + +import qualified Opaleye.SQLite.Internal.Unpackspec as U +import qualified Opaleye.SQLite.Internal.Tag as Tag +import Opaleye.SQLite.Internal.Tag (Tag) +import qualified Opaleye.SQLite.Internal.PrimQuery as PQ + +import qualified Opaleye.SQLite.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) + +runSimpleQueryArrStart :: QueryArr a b -> a -> (b, PQ.PrimQuery, Tag) +runSimpleQueryArrStart q a = runSimpleQueryArr q (a, Tag.start) + +runQueryArrUnpack :: U.Unpackspec a b + -> Query a -> ([HPQ.PrimExpr], PQ.PrimQuery, Tag) +runQueryArrUnpack unpackspec q = (primExprs, primQ, endTag) + where (columns, primQ, endTag) = runSimpleQueryArrStart q () + primExprs = U.collectPEs unpackspec 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/SQLite/Internal/RunQuery.hs b/src/Opaleye/SQLite/Internal/RunQuery.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/SQLite/Internal/RunQuery.hs @@ -0,0 +1,160 @@ +{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-} + +module Opaleye.SQLite.Internal.RunQuery where + +import Control.Applicative (Applicative, pure, (<$>), (<*>), liftA2) + +import Database.SQLite.Simple.Internal (RowParser) +import Database.SQLite.Simple.FromField (FieldParser, FromField, + fromField) +import qualified Database.SQLite.Simple.Internal as SSI +import Database.SQLite.Simple.FromRow (fieldWith) +import qualified Database.SQLite3 as SQLiteBase + +import Opaleye.SQLite.Column (Column) +import Opaleye.SQLite.Internal.Column (Nullable) +import qualified Opaleye.SQLite.Internal.PackMap as PackMap +import qualified Opaleye.SQLite.Column as C +import qualified Opaleye.SQLite.Internal.Unpackspec as U +import qualified Opaleye.SQLite.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.ByteString as SBS +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Time as Time +import GHC.Int (Int64) + +-- | A 'QueryRunnerColumn' @pgType@ @haskellType@ encodes how to turn +-- a value of Postgres type @pgType@ into a value of Haskell type +-- @haskellType@. For example a value of type 'QueryRunnerColumn' +-- 'T.PGText' 'String' encodes how to turn a 'PGText' result from the +-- database into a Haskell 'String'. + +-- This is *not* a Product Profunctor because it is the only way I +-- know of to get the instance generation to work for non-Nullable and +-- Nullable types at once. +data QueryRunnerColumn sqlType haskellType = + QueryRunnerColumn (U.Unpackspec (Column sqlType) ()) (FieldParser haskellType) + +data QueryRunner columns haskells = + QueryRunner (U.Unpackspec columns ()) + (columns -> RowParser haskells) + -- We never actually + -- look at the columns + -- except to see its + -- "type" in the case + -- of a sum profunctor + (columns -> Bool) + -- ^ Have we actually requested any columns? If we + -- asked for zero columns then the SQL generator will + -- have to put a dummy 0 into the SELECT statement, + -- since we can't select zero columns. In that case we + -- have to make sure we read a single Int. + +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 (const (fieldWith fp)) (const True) + where QueryRunnerColumn u fp = qrc + +queryRunnerColumnNullable :: QueryRunnerColumn a b + -> QueryRunnerColumn (Nullable a) (Maybe b) +queryRunnerColumnNullable qr = + QueryRunnerColumn (P.lmap C.unsafeCoerceColumn u) (fromField' fp) + where QueryRunnerColumn u fp = qr + fromField' :: FieldParser a -> FieldParser (Maybe a) + fromField' _ (SSI.Field SQLiteBase.SQLNull _) = pure Nothing + fromField' fp' f = fmap Just (fp' f) + +-- { 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. + +-- | A 'QueryRunnerColumnDefault' @pgType@ @haskellType@ represents +-- the default way to turn a @pgType@ result from the database into a +-- Haskell value of type @haskelType@. +class QueryRunnerColumnDefault pgType haskellType where + queryRunnerColumnDefault :: QueryRunnerColumn pgType haskellType + +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.PGBytea SBS.ByteString where + queryRunnerColumnDefault = fieldQueryRunnerColumn + +instance QueryRunnerColumnDefault T.PGBytea LBS.ByteString 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 + +-- Boilerplate instances + +instance Functor (QueryRunner c) where + fmap f (QueryRunner u r b) = QueryRunner u ((fmap . fmap) f r) b + +-- TODO: Seems like this one should be simpler! +instance Applicative (QueryRunner c) where + pure = flip (QueryRunner (P.lmap (const ()) PP.empty)) (const False) + . pure + . pure + QueryRunner uf rf bf <*> QueryRunner ux rx bx = + QueryRunner (P.dimap (\x -> (x,x)) (const ()) (uf PP.***! ux)) ((<*>) <$> rf <*> rx) (liftA2 (||) bf bx) + +instance P.Profunctor QueryRunner where + dimap f g (QueryRunner u r b) = + QueryRunner (P.lmap f u) (P.dimap f (fmap g) r) (P.lmap f b) + +instance PP.ProductProfunctor QueryRunner where + empty = PP.defaultEmpty + (***!) = PP.defaultProfunctorProduct + +instance PP.SumProfunctor QueryRunner where + f +++! g = QueryRunner (P.rmap (const ()) (fu PP.+++! gu)) + (PackMap.eitherFunction fr gr) + (either fb gb) + where QueryRunner fu fr fb = f + QueryRunner gu gr gb = g + +-- } diff --git a/src/Opaleye/SQLite/Internal/Sql.hs b/src/Opaleye/SQLite/Internal/Sql.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/SQLite/Internal/Sql.hs @@ -0,0 +1,193 @@ +module Opaleye.SQLite.Internal.Sql where + +import Prelude hiding (product) + +import qualified Opaleye.SQLite.Internal.PrimQuery as PQ + +import qualified Opaleye.SQLite.Internal.HaskellDB.PrimQuery as HPQ +import Opaleye.SQLite.Internal.HaskellDB.PrimQuery (Symbol(Symbol)) +import qualified Opaleye.SQLite.Internal.HaskellDB.Sql as HSql +import qualified Opaleye.SQLite.Internal.HaskellDB.Sql.Default as SD +import qualified Opaleye.SQLite.Internal.HaskellDB.Sql.Generate as SG +import qualified Opaleye.SQLite.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 SelectAttrs = + Star + | SelectAttrs (NEL.NonEmpty (HSql.SqlExpr, Maybe HSql.SqlColumn)) + deriving Show + +data From = From { + attrs :: SelectAttrs, + tables :: [Select], + criteria :: [HSql.SqlExpr], + groupBy :: Maybe (NEL.NonEmpty HSql.SqlExpr), + orderBy :: [(HSql.SqlExpr, HSql.SqlOrder)], + limit :: Maybe Int, + offset :: Maybe Int + } + deriving Show + +data Join = Join { + jJoinType :: JoinType, + jTables :: (Select, Select), + jCond :: HSql.SqlExpr + } + deriving Show + +data Values = Values { + vAttrs :: SelectAttrs, + 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 = SelectAttrs (ensureColumns (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 = SelectAttrs (ensureColumns []) } + +baseTable :: String -> [(Symbol, HPQ.PrimExpr)] -> Select +baseTable name columns = SelectFrom $ + newSelect { attrs = SelectAttrs (ensureColumns (map sqlBinding columns)) + , tables = [Table (HSql.SqlTable 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 = SelectAttrs + (ensureColumns (map attr aggrs)) + , tables = [s] + , groupBy = (Just . groupBy') aggrs } + where --- Grouping by an empty list is not the identity function! + --- In fact it forms one single group. Syntactically one + --- cannot group by nothing in SQL, so we just group by a + --- constant instead. Because "GROUP BY 0" means group by the + --- zeroth column, we instead use an expression rather than a + --- constant. + handleEmpty :: [HSql.SqlExpr] -> NEL.NonEmpty HSql.SqlExpr + handleEmpty = + M.fromMaybe (return (HSql.FunSqlExpr "COALESCE" [HSql.ConstSqlExpr "0" + ,HSql.ConstSqlExpr "0"])) + . NEL.nonEmpty + + groupBy' :: [(symbol, (Maybe aggrOp, HPQ.PrimExpr))] + -> NEL.NonEmpty HSql.SqlExpr + groupBy' = (handleEmpty + . map sqlExpr + . map expr + . filter (M.isNothing . aggrOp)) + 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 -> HPQ.PrimExpr -> Select -> Select -> Select +join j cond s1 s2 = SelectJoin Join { jJoinType = joinType j + , jTables = (s1, s2) + , jCond = sqlExpr cond } + +-- 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 = SelectAttrs (mkColumns columns) + , vValues = (map . map) sqlExpr pes } + where mkColumns = ensureColumns . 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 = SelectAttrs + (ensureColumns (map (mkColumn fst) pes)), + tables = [select1] }, + bSelect2 = SelectFrom newSelect { attrs = SelectAttrs + (ensureColumns (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 = Star, + tables = [], + criteria = [], + groupBy = Nothing, + 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))) + +ensureColumns :: [(HSql.SqlExpr, Maybe a)] + -> NEL.NonEmpty (HSql.SqlExpr, Maybe a) +ensureColumns = M.fromMaybe (return (HSql.ConstSqlExpr "0", Nothing)) + . NEL.nonEmpty diff --git a/src/Opaleye/SQLite/Internal/Table.hs b/src/Opaleye/SQLite/Internal/Table.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/SQLite/Internal/Table.hs @@ -0,0 +1,162 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE Rank2Types #-} + +module Opaleye.SQLite.Internal.Table where + +import Opaleye.SQLite.Internal.Column (Column, unColumn) +import qualified Opaleye.SQLite.Internal.TableMaker as TM +import qualified Opaleye.SQLite.Internal.Tag as Tag +import qualified Opaleye.SQLite.Internal.PrimQuery as PQ +import qualified Opaleye.SQLite.Internal.PackMap as PM + +import qualified Opaleye.SQLite.Internal.HaskellDB.PrimQuery as HPQ + +import qualified Data.Functor.Identity as I +import Data.Profunctor (Profunctor, dimap, lmap) +import Data.Profunctor.Product (ProductProfunctor, empty, (***!)) +import qualified Data.Profunctor.Product as PP +import qualified Data.List.NonEmpty as NEL +import Data.Monoid (Monoid, mempty, mappend) +import Control.Applicative (Applicative, pure, (<*>), liftA2) +import qualified Control.Arrow as Arr + +-- | 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 + +-- 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. +-- +-- Writer has become very mysterious. I really couldn't tell you what +-- it means. It seems to be saying that a `Writer` tells you how an +-- `f columns` contains a list of `(f HPQ.PrimExpr, String)`, i.e. how +-- it contains each column: a column header and the entries in this +-- column for all the rows. +newtype Writer columns dummy = + Writer (forall f. Functor f => + PM.PackMap (f HPQ.PrimExpr, String) () (f 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 (outColumns, ()) = f extract (I.Identity columns) + extract (pes, s) = ([(I.runIdentity pes, s)], ()) + +-- This works more generally for any "zippable", that is an +-- Applicative that satisfies +-- +-- x == (,) <$> fmap fst x <*> fmap snd x +-- +-- However, I'm unaware of a typeclass for this. +runWriter' :: Writer columns columns' -> NEL.NonEmpty columns -> (NEL.NonEmpty [HPQ.PrimExpr], [String]) +runWriter' (Writer (PM.PackMap f)) columns = Arr.first unZip outColumns + where (outColumns, ()) = f extract columns + extract (pes, s) = ((Zip (fmap return pes), [s]), ()) + +data Zip a = Zip { unZip :: NEL.NonEmpty [a] } + +instance Monoid (Zip a) where + mempty = Zip mempty' + where mempty' = [] `NEL.cons` mempty' + Zip xs `mappend` Zip ys = Zip (NEL.zipWith (++) xs ys) + +required :: String -> Writer (Column a) (Column a) +required columnName = + Writer (PM.PackMap (\f columns -> f (fmap unColumn columns, columnName))) + +optional :: String -> Writer (Maybe (Column a)) (Column a) +optional columnName = + Writer (PM.PackMap (\f columns -> f (fmap maybeUnColumn columns, columnName))) + where maybeUnColumn Nothing = HPQ.DefaultInsertExpr + maybeUnColumn (Just column) = unColumn column + +-- { + +-- 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 (fmap 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/SQLite/Internal/TableMaker.hs b/src/Opaleye/SQLite/Internal/TableMaker.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/SQLite/Internal/TableMaker.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} + +module Opaleye.SQLite.Internal.TableMaker where + +import qualified Opaleye.SQLite.Column as C +import qualified Opaleye.SQLite.Internal.Column as IC +import qualified Opaleye.SQLite.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.SQLite.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.overPM f id + +runColumnMaker :: Applicative f + => ColumnMaker tablecolumns columns + -> (HPQ.PrimExpr -> f HPQ.PrimExpr) + -> tablecolumns -> f columns +runColumnMaker (ColumnMaker f) = PM.traversePM 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/SQLite/Internal/Tag.hs b/src/Opaleye/SQLite/Internal/Tag.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/SQLite/Internal/Tag.hs @@ -0,0 +1,15 @@ +module Opaleye.SQLite.Internal.Tag where + +newtype 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/SQLite/Internal/Unpackspec.hs b/src/Opaleye/SQLite/Internal/Unpackspec.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/SQLite/Internal/Unpackspec.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} + +module Opaleye.SQLite.Internal.Unpackspec where + +import qualified Opaleye.SQLite.Internal.PackMap as PM +import qualified Opaleye.SQLite.Internal.Column as IC +import qualified Opaleye.SQLite.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.SQLite.Internal.HaskellDB.PrimQuery as HPQ + +newtype Unpackspec columns columns' = + -- | An 'Unpackspec' @columns@ @columns'@ allows you to extract and + -- modify a sequence of 'HPQ.PrimExpr's inside a value of type + -- @columns@. + -- + -- For example, the 'Default' instance of type 'Unpackspec' @(Column + -- a, Column b)@ @(Column a, Column b)@ allows you to manipulate or + -- extract the two 'HPQ.PrimExpr's inside a @(Column a, Column b)@. The + -- 'Default' instance of type @Foo (Column a) (Column b) (Column c)@ + -- will allow you to manipulate or extract the three 'HPQ.PrimExpr's + -- contained therein (for a user-defined product type @Foo@, assuming + -- the @makeAdaptorAndInstance@ splice from + -- @Data.Profunctor.Product.TH@ has been run). + -- + -- You can create 'Unpackspec's by hand using 'unpackspecColumn' and + -- the 'Profunctor', 'ProductProfunctor' and 'SumProfunctor' + -- operations. However, in practice users should almost never need + -- to create or manipulate them. Typically they will be created + -- automatically by the 'D.Default' instance. + Unpackspec (PM.PackMap HPQ.PrimExpr HPQ.PrimExpr columns columns') + +-- | Target the single 'HPQ.PrimExpr' inside a 'C.Column' +unpackspecColumn :: Unpackspec (C.Column a) (C.Column a) +unpackspecColumn = Unpackspec + (PM.PackMap (\f (IC.Column pe) -> fmap IC.Column (f pe))) + +-- | Modify all the targeted 'HPQ.PrimExpr's +runUnpackspec :: Applicative f + => Unpackspec columns b + -> (HPQ.PrimExpr -> f HPQ.PrimExpr) + -> columns -> f b +runUnpackspec (Unpackspec f) = PM.traversePM f + +-- | Extract all the targeted 'HPQ.PrimExpr's +collectPEs :: Unpackspec s t -> s -> [HPQ.PrimExpr] +collectPEs unpackspec = fst . runUnpackspec unpackspec f + where f pe = ([pe], pe) + +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 + +instance PP.SumProfunctor Unpackspec where + Unpackspec x1 +++! Unpackspec x2 = Unpackspec (x1 PP.+++! x2) + +--} diff --git a/src/Opaleye/SQLite/Internal/Values.hs b/src/Opaleye/SQLite/Internal/Values.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/SQLite/Internal/Values.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} + +module Opaleye.SQLite.Internal.Values where + +import qualified Opaleye.SQLite.PGTypes as T + +import Opaleye.SQLite.Internal.Column (Column(Column)) +import qualified Opaleye.SQLite.Internal.Unpackspec as U +import qualified Opaleye.SQLite.Internal.Tag as T +import qualified Opaleye.SQLite.Internal.PrimQuery as PQ +import qualified Opaleye.SQLite.Internal.PackMap as PM +import qualified Opaleye.SQLite.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" + +newtype 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.traversePM 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/SQLite/Join.hs b/src/Opaleye/SQLite/Join.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/SQLite/Join.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-} + +module Opaleye.SQLite.Join where + +import qualified Opaleye.SQLite.Internal.Unpackspec as U +import qualified Opaleye.SQLite.Internal.Join as J +import qualified Opaleye.SQLite.Internal.Tag as T +import qualified Opaleye.SQLite.Internal.PrimQuery as PQ +import Opaleye.SQLite.QueryArr (Query) +import qualified Opaleye.SQLite.Internal.QueryArr as Q +import Opaleye.SQLite.Internal.Column (Column(Column)) +import qualified Opaleye.SQLite.PGTypes as T + +import qualified Data.Profunctor.Product.Default as D + +-- | @leftJoin@'s use of the 'D.Default' typeclass means that the +-- compiler will have trouble inferring types. It is strongly +-- recommended that you provide full type signatures when using +-- @leftJoin@. +-- +-- 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 + +-- We don't actually need the Unpackspecs any more, but I'm going to +-- leave them here in case they're ever needed again. I don't want to +-- have to break the API to add them back. +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 _ _ nullmaker qA qB cond = Q.simpleQueryArr q where + q ((), startTag) = ((columnsA, nullableColumnsB), primQueryR, T.next endTag) + where (columnsA, primQueryA, midTag) = Q.runSimpleQueryArr qA ((), startTag) + (columnsB, primQueryB, endTag) = Q.runSimpleQueryArr qB ((), midTag) + + nullableColumnsB = J.toNullable nullmaker columnsB + + Column cond' = cond (columnsA, columnsB) + primQueryR = PQ.Join PQ.LeftJoin cond' primQueryA primQueryB diff --git a/src/Opaleye/SQLite/Manipulation.hs b/src/Opaleye/SQLite/Manipulation.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/SQLite/Manipulation.hs @@ -0,0 +1,185 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Opaleye.SQLite.Manipulation (module Opaleye.SQLite.Manipulation, + U.Unpackspec) where + +import qualified Opaleye.SQLite.Internal.Sql as Sql +import qualified Opaleye.SQLite.Internal.Print as Print +import qualified Opaleye.SQLite.RunQuery as RQ +import qualified Opaleye.SQLite.Internal.RunQuery as IRQ +import qualified Opaleye.SQLite.Table as T +import qualified Opaleye.SQLite.Internal.Table as TI +import Opaleye.SQLite.Internal.Column (Column(Column)) +import Opaleye.SQLite.Internal.Helpers ((.:), (.:.), (.::), (.::.)) +import qualified Opaleye.SQLite.Internal.Unpackspec as U +import Opaleye.SQLite.PGTypes (PGBool) + +import qualified Opaleye.SQLite.Internal.HaskellDB.Sql as HSql +import qualified Opaleye.SQLite.Internal.HaskellDB.Sql.Print as HPrint +import qualified Opaleye.SQLite.Internal.HaskellDB.Sql.Default as SD +import qualified Opaleye.SQLite.Internal.HaskellDB.Sql.Generate as SG + +import qualified Database.SQLite.Simple as PGS + +import qualified Data.Profunctor.Product.Default as D + +--import Data.Int (Int64) +import Data.String (fromString) +import qualified Data.List.NonEmpty as NEL + +type Int64 = () + +arrangeInsert :: T.Table columns a -> columns -> HSql.SqlInsert +arrangeInsert t c = arrangeInsertMany t (return c) + +arrangeInsertSql :: T.Table columns a -> columns -> String +arrangeInsertSql = show . HPrint.ppInsert .: arrangeInsert + +runInsert :: PGS.Connection -> T.Table columns columns' -> columns -> IO Int64 +runInsert conn = PGS.execute_ conn . fromString .: arrangeInsertSql + +arrangeInsertMany :: T.Table columns a -> NEL.NonEmpty columns -> HSql.SqlInsert +arrangeInsertMany (T.Table tableName (TI.TableProperties writer _)) columns = insert + where (columnExprs, columnNames) = TI.runWriter' writer columns + insert = SG.sqlInsert SD.defaultSqlGenerator + tableName columnNames columnExprs + +arrangeInsertManySql :: T.Table columns a -> NEL.NonEmpty columns -> String +arrangeInsertManySql = show . HPrint.ppInsert .: arrangeInsertMany + +runInsertMany :: PGS.Connection + -> T.Table columns columns' + -> [columns] + -> IO Int64 +runInsertMany conn table columns = case NEL.nonEmpty columns of + -- Inserting the empty list is just the same as returning 0 + Nothing -> return () --return 0 + Just columns' -> (PGS.execute_ conn . fromString .: arrangeInsertManySql) table columns' + +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 ignored + -> 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 + returningPEs = U.collectPEs unpackspec (returningf columnsR) + returningSEs = map Sql.sqlExpr returningPEs + +arrangeInsertReturningSql :: U.Unpackspec returned ignored + -> T.Table columnsW columnsR + -> columnsW + -> (columnsR -> returned) + -> String +arrangeInsertReturningSql = show + . Print.ppInsertReturning + .:: arrangeInsertReturning + +runInsertReturningExplicit :: RQ.QueryRunner returned haskells + -> PGS.Connection + -> T.Table columnsW columnsR + -> columnsW + -> (columnsR -> returned) + -> IO [haskells] +runInsertReturningExplicit qr conn t w r = PGS.queryWith_ (rowParser (r v)) conn + (fromString + (arrangeInsertReturningSql u t w r)) + where IRQ.QueryRunner u rowParser _ = qr + --- ^^ TODO: need to make sure we're not trying to read zero rows + TI.Table _ (TI.TableProperties _ (TI.View v)) = t + -- This method of getting hold of the return type feels a bit + -- suspect. I haven't checked it for validity. + +-- | @runInsertReturning@'s use of the 'D.Default' typeclass means that the +-- compiler will have trouble inferring types. It is strongly +-- recommended that you provide full type signatures when using +-- @runInsertReturning@. +runInsertReturning :: (D.Default RQ.QueryRunner returned haskells) + => PGS.Connection + -> T.Table columnsW columnsR + -> columnsW + -> (columnsR -> returned) + -> IO [haskells] +runInsertReturning = runInsertReturningExplicit D.def + +arrangeUpdateReturning :: U.Unpackspec returned ignored + -> T.Table columnsW columnsR + -> (columnsR -> columnsW) + -> (columnsR -> Column PGBool) + -> (columnsR -> returned) + -> Sql.Returning HSql.SqlUpdate +arrangeUpdateReturning unpackspec table updatef cond returningf = + Sql.Returning update returningSEs + where update = arrangeUpdate table updatef cond + TI.Table _ (TI.TableProperties _ (TI.View columnsR)) = table + returningPEs = U.collectPEs unpackspec (returningf columnsR) + returningSEs = map Sql.sqlExpr returningPEs + +arrangeUpdateReturningSql :: U.Unpackspec returned ignored + -> T.Table columnsW columnsR + -> (columnsR -> columnsW) + -> (columnsR -> Column PGBool) + -> (columnsR -> returned) + -> String +arrangeUpdateReturningSql = show + . Print.ppUpdateReturning + .::. arrangeUpdateReturning + +runUpdateReturningExplicit :: RQ.QueryRunner returned haskells + -> PGS.Connection + -> T.Table columnsW columnsR + -> (columnsR -> columnsW) + -> (columnsR -> Column PGBool) + -> (columnsR -> returned) + -> IO [haskells] +runUpdateReturningExplicit qr conn t update cond r = + PGS.queryWith_ (rowParser (r v)) conn + (fromString (arrangeUpdateReturningSql u t update cond r)) + where IRQ.QueryRunner u rowParser _ = qr + --- ^^ TODO: need to make sure we're not trying to read zero rows + TI.Table _ (TI.TableProperties _ (TI.View v)) = t + +runUpdateReturning :: (D.Default RQ.QueryRunner returned haskells) + => PGS.Connection + -> T.Table columnsW columnsR + -> (columnsR -> columnsW) + -> (columnsR -> Column PGBool) + -> (columnsR -> returned) + -> IO [haskells] +runUpdateReturning = runUpdateReturningExplicit D.def diff --git a/src/Opaleye/SQLite/Operators.hs b/src/Opaleye/SQLite/Operators.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/SQLite/Operators.hs @@ -0,0 +1,82 @@ +module Opaleye.SQLite.Operators (module Opaleye.SQLite.Operators) where + +import qualified Data.Foldable as F + +import Opaleye.SQLite.Internal.Column (Column(Column), unsafeCase_, + unsafeIfThenElse, unsafeGt, unsafeEq) +import qualified Opaleye.SQLite.Internal.Column as C +import Opaleye.SQLite.Internal.QueryArr (QueryArr(QueryArr)) +import qualified Opaleye.SQLite.Internal.PrimQuery as PQ +import qualified Opaleye.SQLite.Order as Ord +import qualified Opaleye.SQLite.PGTypes as T + +import qualified Opaleye.SQLite.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 .> +(.>) :: Ord.PGOrd a => Column a -> Column a -> Column T.PGBool +(.>) = unsafeGt + +infix 4 .< +(.<) :: Ord.PGOrd a => Column a -> Column a -> Column T.PGBool +(.<) = C.binOp HPQ.OpLt + +infix 4 .<= +(.<=) :: Ord.PGOrd a => Column a -> Column a -> Column T.PGBool +(.<=) = C.binOp HPQ.OpLtEq + +infix 4 .>= +(.>=) :: Ord.PGOrd a => Column a -> Column a -> Column T.PGBool +(.>=) = C.binOp HPQ.OpGtEq + +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 + +like :: Column T.PGText -> Column T.PGText -> Column T.PGBool +like = C.binOp HPQ.OpLike + +ors :: F.Foldable f => f (Column T.PGBool) -> Column T.PGBool +ors = F.foldl' (.||) (T.pgBool False) + +in_ :: (Functor f, F.Foldable f) => f (Column a) -> Column a -> Column T.PGBool +in_ hs w = ors . fmap (w .==) $ hs diff --git a/src/Opaleye/SQLite/Order.hs b/src/Opaleye/SQLite/Order.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/SQLite/Order.hs @@ -0,0 +1,82 @@ +module Opaleye.SQLite.Order (module Opaleye.SQLite.Order, O.Order) where + +import qualified Opaleye.SQLite.Column as C +import Opaleye.SQLite.QueryArr (Query) +import qualified Opaleye.SQLite.Internal.QueryArr as Q +import qualified Opaleye.SQLite.Internal.Order as O +import qualified Opaleye.SQLite.PGTypes as T + +import qualified Opaleye.SQLite.Internal.HaskellDB.PrimQuery as HPQ + +{-| Order the rows of a `Query` according to the `Order`. + +@ +import Data.Monoid (\<\>) + +\-- Order by the first column ascending. When first columns are equal +\-- order by second column descending. +example :: 'Query' ('C.Column' 'T.PGInt4', 'C.Column' 'T.PGText') + -> 'Query' ('C.Column' 'T.PGInt4', 'C.Column' 'T.PGText') +example = 'orderBy' ('asc' fst \<\> 'desc' snd) +@ + +-} +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. +-- (Any NULLs appear last) +asc :: PGOrd b => (a -> C.Column b) -> O.Order a +asc = O.order HPQ.OrderOp { HPQ.orderDirection = HPQ.OpAsc + , HPQ.orderNulls = HPQ.NullsLast } + +-- | Specify an descending ordering by the given expression. +-- (Any NULLs appear first) +desc :: PGOrd b => (a -> C.Column b) -> O.Order a +desc = O.order HPQ.OrderOp { HPQ.orderDirection = HPQ.OpDesc + , HPQ.orderNulls = HPQ.NullsFirst } + +-- | Specify an ascending ordering by the given expression. +-- (Any NULLs appear first) +ascNullsFirst :: PGOrd b => (a -> C.Column b) -> O.Order a +ascNullsFirst = O.order HPQ.OrderOp { HPQ.orderDirection = HPQ.OpAsc + , HPQ.orderNulls = HPQ.NullsFirst } + + +-- | Specify an descending ordering by the given expression. +-- (Any NULLs appear last) +descNullsLast :: PGOrd b => (a -> C.Column b) -> O.Order a +descNullsLast = O.order HPQ.OrderOp { HPQ.orderDirection = HPQ.OpDesc + , HPQ.orderNulls = HPQ.NullsLast } + +{- | +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) + +-- | Typeclass for Postgres types which support ordering operations. +class PGOrd a where + +instance PGOrd T.PGBool +instance PGOrd T.PGDate +instance PGOrd T.PGFloat8 +instance PGOrd T.PGFloat4 +instance PGOrd T.PGInt8 +instance PGOrd T.PGInt4 +instance PGOrd T.PGInt2 +instance PGOrd T.PGNumeric +instance PGOrd T.PGText +instance PGOrd T.PGTime +instance PGOrd T.PGTimestamptz +instance PGOrd T.PGTimestamp +instance PGOrd T.PGCitext diff --git a/src/Opaleye/SQLite/PGTypes.hs b/src/Opaleye/SQLite/PGTypes.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/SQLite/PGTypes.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE EmptyDataDecls #-} + +module Opaleye.SQLite.PGTypes (module Opaleye.SQLite.PGTypes) where + +import Opaleye.SQLite.Internal.Column (Column) +import qualified Opaleye.SQLite.Internal.Column as C +import qualified Opaleye.SQLite.Internal.PGTypes as IPT + +import qualified Opaleye.SQLite.Internal.HaskellDB.PrimQuery as HPQ +import qualified Opaleye.SQLite.Internal.HaskellDB.Sql.Default as HSD (quote) + +import qualified Data.CaseInsensitive as CI +import qualified Data.Text as SText +import qualified Data.Text.Lazy as LText +import qualified Data.ByteString as SByteString +import qualified Data.ByteString.Lazy as LByteString +import qualified Data.Time as Time +import qualified Data.UUID as UUID + +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 +data PGCitext +data PGArray a +data PGBytea +data PGJson +data PGJsonb + +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 = IPT.literalColumn +{-# WARNING literalColumn + "'literalColumn' has been moved to Opaleye.Internal.PGTypes" + #-} + +pgString :: String -> Column PGText +pgString = IPT.literalColumn . HPQ.StringLit + +pgLazyByteString :: LByteString.ByteString -> Column PGBytea +pgLazyByteString = IPT.literalColumn . HPQ.ByteStringLit . LByteString.toStrict + +pgStrictByteString :: SByteString.ByteString -> Column PGBytea +pgStrictByteString = IPT.literalColumn . HPQ.ByteStringLit + +pgStrictText :: SText.Text -> Column PGText +pgStrictText = IPT.literalColumn . HPQ.StringLit . SText.unpack + +pgLazyText :: LText.Text -> Column PGText +pgLazyText = IPT.literalColumn . HPQ.StringLit . LText.unpack + +pgInt4 :: Int -> Column PGInt4 +pgInt4 = IPT.literalColumn . HPQ.IntegerLit . fromIntegral + +pgInt8 :: Int64 -> Column PGInt8 +pgInt8 = IPT.literalColumn . HPQ.IntegerLit . fromIntegral + +-- SQLite needs to be told that numeric literals without decimal +-- points are actual REAL +pgDouble :: Double -> Column PGFloat8 +pgDouble = C.unsafeCast "REAL" . IPT.literalColumn . HPQ.DoubleLit + +pgBool :: Bool -> Column PGBool +pgBool = IPT.literalColumn . HPQ.BoolLit + +pgUUID :: UUID.UUID -> Column PGUuid +pgUUID = C.unsafeCoerceColumn . pgString . UUID.toString + +unsafePgFormatTime :: Time.FormatTime t => HPQ.Name -> String -> t -> Column c +unsafePgFormatTime = IPT.unsafePgFormatTime +{-# WARNING unsafePgFormatTime + "'unsafePgFormatTime' has been moved to Opaleye.Internal.PGTypes" + #-} + +pgDay :: Time.Day -> Column PGDate +pgDay = IPT.unsafePgFormatTime "date" "'%F'" + +pgUTCTime :: Time.UTCTime -> Column PGTimestamptz +pgUTCTime = IPT.unsafePgFormatTime "timestamptz" "'%FT%TZ'" + +pgLocalTime :: Time.LocalTime -> Column PGTimestamp +pgLocalTime = IPT.unsafePgFormatTime "timestamp" "'%FT%T'" + +pgTimeOfDay :: Time.TimeOfDay -> Column PGTime +pgTimeOfDay = IPT.unsafePgFormatTime "time" "'%T'" + +-- "We recommend not using the type time with time zone" +-- http://www.postgresql.org/docs/8.3/static/datatype-datetime.html + + +pgCiStrictText :: CI.CI SText.Text -> Column PGCitext +pgCiStrictText = IPT.literalColumn . HPQ.StringLit . SText.unpack . CI.original + +pgCiLazyText :: CI.CI LText.Text -> Column PGCitext +pgCiLazyText = IPT.literalColumn . HPQ.StringLit . LText.unpack . CI.original + +-- No CI String instance since postgresql-simple doesn't define FromField (CI String) + +-- The json data type was introduced in PostgreSQL version 9.2 +-- JSON values must be SQL string quoted +pgJSON :: String -> Column PGJson +pgJSON = IPT.castToType "json" . HSD.quote + +pgStrictJSON :: SByteString.ByteString -> Column PGJson +pgStrictJSON = pgJSON . IPT.strictDecodeUtf8 + +pgLazyJSON :: LByteString.ByteString -> Column PGJson +pgLazyJSON = pgJSON . IPT.lazyDecodeUtf8 + +-- The jsonb data type was introduced in PostgreSQL version 9.4 +-- JSONB values must be SQL string quoted +-- +-- TODO: We need to add literal JSON and JSONB types. +pgJSONB :: String -> Column PGJsonb +pgJSONB = IPT.castToType "jsonb" . HSD.quote + +pgStrictJSONB :: SByteString.ByteString -> Column PGJsonb +pgStrictJSONB = pgJSONB . IPT.strictDecodeUtf8 + +pgLazyJSONB :: LByteString.ByteString -> Column PGJsonb +pgLazyJSONB = pgJSONB . IPT.lazyDecodeUtf8 diff --git a/src/Opaleye/SQLite/QueryArr.hs b/src/Opaleye/SQLite/QueryArr.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/SQLite/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.SQLite.QueryArr (QueryArr, Query) where + +import Opaleye.SQLite.Internal.QueryArr (QueryArr, Query) diff --git a/src/Opaleye/SQLite/RunQuery.hs b/src/Opaleye/SQLite/RunQuery.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/SQLite/RunQuery.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Opaleye.SQLite.RunQuery (module Opaleye.SQLite.RunQuery, + QueryRunner, + IRQ.QueryRunnerColumn, + IRQ.fieldQueryRunnerColumn) where + +import qualified Database.SQLite.Simple as PGS +import qualified Database.SQLite.Simple.FromRow as FR +import qualified Data.String as String + +import Opaleye.SQLite.Column (Column) +import qualified Opaleye.SQLite.Sql as S +import Opaleye.SQLite.QueryArr (Query) +import Opaleye.SQLite.Internal.RunQuery (QueryRunner(QueryRunner)) +import qualified Opaleye.SQLite.Internal.RunQuery as IRQ +import qualified Opaleye.SQLite.Internal.QueryArr as Q + +import qualified Data.Profunctor as P +import qualified Data.Profunctor.Product.Default as D + +import Control.Applicative ((*>)) + +-- | @runQuery@'s use of the 'D.Default' typeclass means that the +-- compiler will have trouble inferring types. It is strongly +-- recommended that you provide full type signatures when using +-- @runQuery@. +-- +-- 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 nonZeroColumns) conn q = + PGS.queryWith_ parser conn sql + where sql :: PGS.Query + sql = String.fromString (S.showSqlForPostgresExplicit u q) + -- FIXME: We're doing work twice here + (b, _, _) = Q.runSimpleQueryArrStart q () + parser = if nonZeroColumns b + then rowParser b + else (FR.fromRow :: FR.RowParser (PGS.Only Int)) *> rowParser b + -- If we are selecting zero columns then the SQL + -- generator will have to put a dummy 0 into the + -- SELECT statement, since we can't select zero + -- columns. In that case we have to make sure we + -- read a single Int. + +-- | 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 diff --git a/src/Opaleye/SQLite/Sql.hs b/src/Opaleye/SQLite/Sql.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/SQLite/Sql.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-} + +module Opaleye.SQLite.Sql where + +import qualified Opaleye.SQLite.Internal.HaskellDB.PrimQuery as HPQ + +import qualified Opaleye.SQLite.Internal.Unpackspec as U +import qualified Opaleye.SQLite.Internal.Sql as Sql +import qualified Opaleye.SQLite.Internal.Print as Pr +import qualified Opaleye.SQLite.Internal.PrimQuery as PQ +import qualified Opaleye.SQLite.Internal.Optimize as Op +import Opaleye.SQLite.Internal.Helpers ((.:)) +import qualified Opaleye.SQLite.Internal.QueryArr as Q +import qualified Opaleye.SQLite.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/SQLite/SqlTypes.hs b/src/Opaleye/SQLite/SqlTypes.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/SQLite/SqlTypes.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE EmptyDataDecls #-} + +module Opaleye.SQLite.SqlTypes (module Opaleye.SQLite.SqlTypes) where + +import Opaleye.SQLite.Internal.Column (Column) +import qualified Opaleye.SQLite.PGTypes as PT +import qualified Opaleye.SQLite.Internal.PGTypes as IPT + +import qualified Opaleye.SQLite.Internal.HaskellDB.PrimQuery as HPQ + +import qualified Data.Text as SText +import qualified Data.Text.Lazy as LText +import qualified Data.Time as Time + +-- These probably don't correspond very well to SQLite types yet. +-- Work in progress. +type SqlBool = PT.PGBool +type SqlDate = PT.PGDate +type SqlReal = PT.PGFloat8 +type SqlText = PT.PGText +type SqlInt = PT.PGInt4 + +sqlString :: String -> Column SqlText +sqlString = PT.pgString + +sqlStrictText :: SText.Text -> Column SqlText +sqlStrictText = PT.pgStrictText + +sqlLazyText :: LText.Text -> Column SqlText +sqlLazyText = PT.pgLazyText + +sqlInt :: Int -> Column SqlInt +sqlInt = PT.pgInt4 + +sqlReal :: Double -> Column SqlReal +sqlReal = PT.pgDouble + +sqlBool :: Bool -> Column SqlBool +sqlBool = PT.pgBool diff --git a/src/Opaleye/SQLite/Table.hs b/src/Opaleye/SQLite/Table.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/SQLite/Table.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Opaleye.SQLite.Table (module Opaleye.SQLite.Table, + View, + Writer, + Table(Table), + TableProperties) where + +import Opaleye.SQLite.Internal.Column (Column(Column)) +import qualified Opaleye.SQLite.Internal.QueryArr as Q +import qualified Opaleye.SQLite.Internal.Table as T +import Opaleye.SQLite.Internal.Table (View(View), Table, Writer, + TableProperties) +import qualified Opaleye.SQLite.Internal.TableMaker as TM +import qualified Opaleye.SQLite.Internal.Tag as Tag + +import qualified Data.Profunctor.Product.Default as D + +import qualified Opaleye.SQLite.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 + (T.required columnName) + (View (Column (HPQ.BaseTableAttrExpr columnName))) + +optional :: String -> TableProperties (Maybe (Column a)) (Column a) +optional columnName = T.TableProperties + (T.optional columnName) + (View (Column (HPQ.BaseTableAttrExpr columnName))) diff --git a/src/Opaleye/SQLite/Values.hs b/src/Opaleye/SQLite/Values.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/SQLite/Values.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Opaleye.SQLite.Values where + +import qualified Opaleye.SQLite.Internal.QueryArr as Q +import Opaleye.SQLite.QueryArr (Query) +import Opaleye.SQLite.Internal.Values as V +import qualified Opaleye.SQLite.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)