packages feed

opaleye-sqlite (empty) → 0.0.0.0

raw patch · 52 files changed

+5597/−0 lines, 52 filesdep +QuickCheckdep +basedep +base16-bytestringsetup-changed

Dependencies added: QuickCheck, base, base16-bytestring, bytestring, case-insensitive, containers, contravariant, direct-sqlite, opaleye-sqlite, pretty, product-profunctors, profunctors, semigroups, sqlite-simple, text, time, time-locale-compat, transformers, uuid, void

Files

+ Doc/Tutorial/DefaultExplanation.lhs view
@@ -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.
+ Doc/Tutorial/Main.hs view
@@ -0,0 +1,7 @@+import TutorialBasic ()+import TutorialManipulation ()+import TutorialAdvanced ()+import DefaultExplanation ()++main :: IO ()+main = return ()
+ Doc/Tutorial/TutorialAdvanced.lhs view
@@ -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
+ Doc/Tutorial/TutorialBasic.lhs view
@@ -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
+ Doc/Tutorial/TutorialManipulation.lhs view
@@ -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.
+ Doc/UPGRADING.md view
@@ -0,0 +1,104 @@+# Changes since version 0++This document pertains to changes between various old pre-release+versions of Opaleye and the first release to Hackage.  It is+irrelevant to you if you have only used Opaleye since its first+Hackage release.++## Changes visible in the API++### `Wire` becomes `Column`.  `ExprArr` is gone.++The most important user-visible difference between Opaleye 0 and+Opaleye 1 is that `Wire` is now called `Column`.  This is not just a+cosmetic change.  `Column` contains an entire SQL expression rather+than just a column reference.  That is, it contains what used to be+`ExprArr`.  The benefit is that manipulating SQL expressions no longer+needs the hassle of `ExprArr`.  For example, numerical operations can+be expressed succinctly++    calculation = proc () -> do+        (a, b, c) <- table -< ()+        returnA -< a + ifThenElse (b .== c) (b * c) (a / 2)++### Namespace changes++The namespace has changed from Karamaan.Opaleye to Opaleye.  Many of+the version 0 modules were very cluttered with deprecated names.  They+have been cleaned and tidied.++### Tables have type parameters for writing and reading++Tables now have two type parameters.  One indicates how to use it for+writing, the other for reading.++### `Nullable` is no longer a synonym for `Maybe`++`Nullable` is now a new type independent of `Maybe`.  `runQuery` still+converts it to `Maybe` but Opaleye-side code should use `Nullable`+instead of `Maybe`.++### `ShowConstant` doesn't exist++The `ShowConstant` typeclass for lifting Haskell values into Opaleye+does not exist anymore.  Instead there is a `PGTypes` module with+individual functions for lifting values.  If after due consideration+it seems like the typeclass was needed after all it can be added back+in.++## Internal changes++### SQL generation++Opaleye 1 uses less of HaskellDB's SQL generator.  HaskellDB's+optimizer is extremely buggy and its SQL generator does not support+`OUTER JOIN` or `VALUES`.  It would have been more difficult to work+around or patch HaskellDB than simply to write a new SQL generator for+Opaleye, so we did the latter.++### `PackMap`++Many or most of the product profunctors in use in Opaleye 0 have been+unified as values of specific type called `PackMap` which seems very+similar to a "traversal" from `Control.Lens`.  This cuts down on a lot+of boilerplate and allows unification of concepts and functionality.++## Converting from version 0++Please note that although almost all of Opaleye 0's functionality is+now present in Opaleye 1, we are still missing the implementation of+many operators and instances.  This is a very small amount of work and+would be a good starter project.  Patches for this are welcome.  For+example++* `RunQuery` is fully implemented but most of the `QueryRunner`+  instances just need to be written down.+* Support for numeric, boolean, etc. operators is fully+  implemented but many of them still need to be written down.+* Support for binary set operations and `OUTER JOIN`s is fully+  implemented but the definitions of `UNION`, `INTERSECT`,+  `INTERSECT ALL`, `RIGHT JOIN`, `FULL OUTER JOIN` etc. still need+  to be written down.++Opaleye 0 and Opaleye 1 can exist together in the same codebase+because they have different package names and different module+namespaces.  However, I would recommend converting to Opaleye 1 and+writing all new code with Opaleye 1 because it is easier to use.++Converting from Opaleye 0 to Opaleye 1 might be smoother if you+provide the following synonyms during the transition.++    type Wire = Column+    type ExprArr = (->)++    toQueryArrDef :: ExprArr a b -> QueryArr a b+    toQueryArrDef = arr++Information about how well this works in practice would be gratefully+received.++You will probably find that many identifiers have changed,+particularly fully qualified identifiers.  Theoretically a transition+package could be provided that maps from the old names to the new+names, but I suspect this is likely to be more work than just changing+all the old uses by hand.
+ README.md view
@@ -0,0 +1,4 @@+# `opaleye-sqlite`++A preliminary version of Opaleye for SQLite.  There may be many rough+edges!
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Test/QuickCheck.hs view
@@ -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)++-- }
+ Test/Test.hs view
@@ -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)
+ opaleye-sqlite.cabal view
@@ -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
+ src/Opaleye/SQLite.hs view
@@ -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
+ src/Opaleye/SQLite/Aggregate.hs view
@@ -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
+ src/Opaleye/SQLite/Binary.hs view
@@ -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)
+ src/Opaleye/SQLite/Column.hs view
@@ -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
+ src/Opaleye/SQLite/Distinct.hs view
@@ -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
+ src/Opaleye/SQLite/Internal/Aggregate.hs view
@@ -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)++-- }
+ src/Opaleye/SQLite/Internal/Binary.hs view
@@ -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++-- }
+ src/Opaleye/SQLite/Internal/Column.hs view
@@ -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
+ src/Opaleye/SQLite/Internal/Distinct.hs view
@@ -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)++-- }
+ src/Opaleye/SQLite/Internal/HaskellDB/PrimQuery.hs view
@@ -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)
+ src/Opaleye/SQLite/Internal/HaskellDB/Sql.hs view
@@ -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])
+ src/Opaleye/SQLite/Internal/HaskellDB/Sql/Default.hs view
@@ -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) ++ "'"
+ src/Opaleye/SQLite/Internal/HaskellDB/Sql/Generate.hs view
@@ -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+    }
+ src/Opaleye/SQLite/Internal/HaskellDB/Sql/Print.hs view
@@ -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
+ src/Opaleye/SQLite/Internal/Helpers.hs view
@@ -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)
+ src/Opaleye/SQLite/Internal/Join.hs view
@@ -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')++--
+ src/Opaleye/SQLite/Internal/Optimize.hs view
@@ -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 _ = []
+ src/Opaleye/SQLite/Internal/Order.hs view
@@ -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)
+ src/Opaleye/SQLite/Internal/PGTypes.hs view
@@ -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
+ src/Opaleye/SQLite/Internal/PackMap.hs view
@@ -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++-- }
+ src/Opaleye/SQLite/Internal/PrimQuery.hs view
@@ -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
+ src/Opaleye/SQLite/Internal/Print.hs view
@@ -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
+ src/Opaleye/SQLite/Internal/QueryArr.hs view
@@ -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+  (***!) = (***)
+ src/Opaleye/SQLite/Internal/RunQuery.hs view
@@ -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++-- }
+ src/Opaleye/SQLite/Internal/Sql.hs view
@@ -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
+ src/Opaleye/SQLite/Internal/Table.hs view
@@ -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)++-- }
+ src/Opaleye/SQLite/Internal/TableMaker.hs view
@@ -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++--}
+ src/Opaleye/SQLite/Internal/Tag.hs view
@@ -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)
+ src/Opaleye/SQLite/Internal/Unpackspec.hs view
@@ -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)++--}
+ src/Opaleye/SQLite/Internal/Values.hs view
@@ -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++-- }
+ src/Opaleye/SQLite/Join.hs view
@@ -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
+ src/Opaleye/SQLite/Manipulation.hs view
@@ -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
+ src/Opaleye/SQLite/Operators.hs view
@@ -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
+ src/Opaleye/SQLite/Order.hs view
@@ -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
+ src/Opaleye/SQLite/PGTypes.hs view
@@ -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
+ src/Opaleye/SQLite/QueryArr.hs view
@@ -0,0 +1,9 @@+{-|++This modules defines the 'QueryArr' arrow, which is an arrow that represents+selecting data from a database, and composing multiple queries together.++-}+module Opaleye.SQLite.QueryArr (QueryArr, Query) where++import           Opaleye.SQLite.Internal.QueryArr (QueryArr, Query)
+ src/Opaleye/SQLite/RunQuery.hs view
@@ -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
+ src/Opaleye/SQLite/Sql.hs view
@@ -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
+ src/Opaleye/SQLite/SqlTypes.hs view
@@ -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
+ src/Opaleye/SQLite/Table.hs view
@@ -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)))
+ src/Opaleye/SQLite/Values.hs view
@@ -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)