generic-persistence 0.2.0.1 → 0.3.0.0

raw patch · 16 files changed

+1263/−1162 lines, 16 filesdep +generic-derivingdep −bytestringdep −exceptionsdep −ghc

Dependencies added: generic-deriving

Dependencies removed: bytestring, exceptions, ghc, ghc-prim, rio, syb, text, time, transformers

Files

• README.md +293/−187
• app/Main.hs +128/−76
• generic-persistence.cabal +8/−33
• src/Database/GP.hs +11/−17
• src/Database/GP/Conn.hs +61/−0
• src/Database/GP/Entity.hs +121/−87
• src/Database/GP/GenericPersistence.hs +127/−116
• src/Database/GP/RecordtypeReflection.hs +0/−146
• src/Database/GP/SqlGenerator.hs +56/−64
• src/Database/GP/TypeInfo.hs +56/−45
• test/EmbeddedSpec.hs +57/−51
• test/EnumSpec.hs +33/−40
• test/GenericPersistenceSpec.hs +163/−145
• test/OneToManySpec.hs +80/−98
• test/ReferenceSpec.hs +65/−55
• test/Spec.hs +4/−2

@@ -1,13 +1,13 @@-# GenericPersistence - A Haskell persistence layer using Generics and Reflection+# GenericPersistence - A Haskell Persistence Layer using Generics  [![Actions Status](https://github.com/thma/generic-persistence/workflows/Haskell%20CI/badge.svg)](https://github.com/thma/generic-persistence/actions) -![GP Logo](gp-logo-300.png)+![GP Logo](https://github.com/thma/generic-persistence/blob/main/gp-logo-300.png?raw=true)  ## Introduction -GenericPersistence is a minimalistic Haskell persistence layer (on top of HDBC). -The approach relies on Generics (`Data.Data`, `Data.Typeable`) and Reflection (`Type.Reflection`).+GenericPersistence is a minimalistic Haskell persistence layer for relational databases. +The approach relies on [GHC.Generics](https://hackage.haskell.org/package/base-4.17.0.0/docs/GHC-Generics.html). The actual database access is provided by the [HDBC](https://hackage.haskell.org/package/HDBC) library.  The *functional goal* of the persistence layer is to provide hassle-free RDBMS persistence for Haskell data types in  Record notation (for brevity I call them *Entities*).@@ -25,13 +25,20 @@ In an ideal world we would be able to take any POHO (Plain old Haskell Object)  and persist it to any RDBMS without any additional effort. -A lot of things are still missing:+## Status +The library is in an early stage of development. All test cases are green and it should be ready for early adopters.+Several things are still missing:+ - A query language-- Handling of nested transactions - Handling auto-incrementing primary keys+- caching+- coding free support for 1:1 and 1:n relationships (using more generics magic)+- schema migration - ... +Feature requests, feedback and pull requests are welcome!+ ## Available on Hackage  [https://hackage.haskell.org/package/generic-persistence](https://hackage.haskell.org/package/generic-persistence)@@ -43,24 +50,28 @@ - generic-persistence ``` +I would also recommend to add the setting `language: GHC2021`  to your `package.yaml` file:++```yaml+language: GHC2021+```++This drastically reduces the amount of LANGUAGE extensions that need to be added to your source files.++ ## Short demo  Here now follows a short demo that shows how the library looks and feels from the user's point of view.  ```haskell--- allows automatic derivation from Entity type class-{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveAnyClass #-} -- allows automatic derivation from Entity type class  module Main (main) where -import           Data.Data             (Data)-import           Database.GP           (Entity (..), GP, delete, insert, liftIO,-                                        persist, retrieveAll, retrieveById,-                                        runGP, setupTableFor, update)-import           Database.HDBC         (IConnection (disconnect), fromSql,-                                        toSql)-import           Database.HDBC.Sqlite3 (connectSqlite3)-+import           Database.GP         +import           Database.HDBC+import           Database.HDBC.Sqlite3+import           GHC.Generics  -- | An Entity data type with several fields, using record syntax. data Person = Person@@ -69,86 +80,167 @@     age      :: Int,     address  :: String   }-  deriving (Data, Entity, Show) -- deriving Entity allows to handle the type with GenericPersistence+  deriving (Generic, Entity, Show) -- deriving Entity allows us to use the GenericPersistence API -data Book = Book-  { book_id :: Int,-    title   :: String,-    author  :: String,-    year    :: Int-  }-  deriving (Data, Show) -- no auto deriving of Entity, so we have to implement the Entity type class: -instance Entity Book where-  -- this is the primary key field of the Book data type-  idField _ = "book_id"+main :: IO ()+main = do+  -- connect to a database+  conn <- connect SQLite <$> connectSqlite3 "sqlite.db" -  -- this defines the mapping between the field names of the Book data type and the column names of the database table-  fieldsToColumns _ = [("book_id", "bookId"), ("title", "bookTitle"), ("author", "bookAuthor"), ("year", "bookYear")]+  -- initialize Person table+  setupTableFor @Person conn -  -- this is the name of the database table-  tableName _ = "BOOK_TBL"+  -- create a Person entity+  let alice = Person {personID = 123456, name = "Alice", age = 25, address = "Elmstreet 1"} -  -- this is the function that converts a row from the database table into a Book data type-  fromRow row = return $ Book (col 0) (col 1) (col 2) (col 3)-    where-      col i = fromSql (row !! i)+  -- insert a Person into a database+  insert conn alice -  -- this is the function that converts a Book data type into a row for the database table-  toRow b = return [toSql (book_id b), toSql (title b), toSql (author b), toSql (year b)]+  -- update a Person+  update conn alice {address = "Main Street 200"} -main :: IO ()-main = do-  -- connect to a database-  conn <- connectSqlite3 "sqlite.db"-  -- take the connection and execute all persistence operations in the GP monad (type alias for RIO Ctx)-  runGP conn $ do-    _ <- setupTableFor :: GP Person-    _ <- setupTableFor :: GP Book+  -- select a Person from a database+  -- The result type must be provided by the call site, +  -- as `retrieveEntityById` has a polymorphic return type `IO (Maybe a)`.+  alice' <- retrieveById @Person conn "123456" +  print alice' -    let alice = Person 123456 "Alice" 25 "123 Main St"-        book = Book 1 "The Hobbit" "J.R.R. Tolkien" 1937+  -- select all Persons from a database+  allPersons <- retrieveAll @Person conn+  print allPersons -    -- insert a Person into the database (persist will either insert or update)-    persist alice+  -- delete a Person from a database+  delete conn alice -    -- insert a second Person-    persist alice {personID = 123457, name = "Bob"}+  -- select all Persons from a database. Now it should be empty.+  allPersons' <- retrieveAll conn :: IO [Person]+  print allPersons' -    -- update a Person-    persist alice {address = "Elmstreet 1"}+  -- close connection+  disconnect conn+``` -    -- select a Person from a database-    alice' <- retrieveById (123456 :: Int) :: GP (Maybe Person)-    liftIO $ print alice'+## How it works -    -- select all Persons from the database-    allPersons <- retrieveAll :: GP [Person]-    liftIO $ print allPersons+In order to store Haskell data types in a relational database, we need to define a mapping between Haskell types and database tables.+This mapping is defined by the `Entity` type class. This type class comes with default implementations for all methods which define +the standard behaviour. (The default implementations internally use `GHC.Generics`.) -    -- delete a Person-    delete alice+This default mapping will work for many cases, but it can be customized by overriding the default implementations. -    -- select all Persons from a database. The deleted Person is not in the result.-    allPersons' <- retrieveAll :: GP [Person]-    liftIO $ print allPersons'+### The Entity type class -    let book2 = Book {book_id = 2, title = "The Lord of the Ring", author = "J.R.R. Tolkien", year = 1954}+The `Entity` type class specifies the following methods: -    -- this time we are using insert directly-    insert book-    insert book2-    allBooks <- retrieveAll :: GP [Book]-    liftIO $ print allBooks+```haskell+class (Generic a, HasConstructor (Rep a), HasSelectors (Rep a)) => Entity a where+  -- | Converts a database row to a value of type 'a'.+  fromRow :: Conn -> [SqlValue] -> IO a -    -- explicitly updating a Book-    update book2 {title = "The Lord of the Rings"}-    delete book+  -- | Converts a value of type 'a' to a database row.+  toRow :: Conn -> a -> IO [SqlValue] -    allBooks' <- retrieveAll :: GP [Book]-    liftIO $ print allBooks'+  -- | Returns the name of the primary key field for a type 'a'.+  idField :: String++  -- | Returns a list of tuples that map field names to column names for a type 'a'.+  fieldsToColumns :: [(String, String)]++  -- | Returns the name of the table for a type 'a'.+  tableName :: String ``` +### Default Behaviour++`idField`, `fieldsToColumns` and `tableName` are used to define the mapping between Haskell types and database tables.++- The default implementations of `idField` returns a default value for the field name of the primary key field of a type `a`:+The type name in lower case, plus "ID".+E.g. `idField @Book` will return `"bookID"`.++- `tableName` returns the name of the database table used for type `a`. The default implementation simply returns the constructor name of `a`. E.g. `tableName @Book` will return `"Book"`.++- `fieldsToColumns` returns a list of tuples that map field names of type `a` to database column names for a type. The default implementation simply returns a list of tuples that map the field names of `a` to the field names of `a`. E.g. `fieldsToColumns @Person` will return `[("personID","personID"),("name","name"),("age","age"),("address","address")]`.++`fromRow` and `toRow` are used to convert between Haskell types and database rows. ++- `fromRow` converts a database row, represented by a `[SqlValue]` to a value of type `a`. ++- `toRow` converts a value of type `a` to a `[SqlValue]`, representing a database row. ++The default implementations of `fromRow` and `toRow` expects that type `a` has a single constructor and a selector for each field. All fields are expected to have a 1:1 mapping to a column in the database table.+Thus each field must have a type that can be converted to and from a `SqlValue`. ++For example ++```haskell+toRow conn (Person {personID = 1234, name = "Alice", age = 27, address = "Elmstreet 1"}) +````++will return ++```haskell+[SqlInt64 1234,SqlString "Alice",SqlInt64 27,SqlString "Elmstreet 1"]+```++And `fromRow` does the inverse: +```haskell+fromRow conn [SqlInt64 1234,SqlString "Alice",SqlInt64 27,SqlString "Elmstreet 1"] :: IO Person+``` ++returns ++```haskell+Person {personID = 1234, name = "Alice", age = 27, address = "Elmstreet 1"}+```++The conversion functions `toRow` and `fromRow` both carry an additional `Conn` argument. This argument is not used by the default implementations, but it can be used to provide database access during the conversion process. We will cover this later.++### Customizing the default behaviour++The default implementations of `idField`, `fieldsToColumns`, `tableName`, `fromRow` and `toRow` can be customized by overriding the default implementations.+Overiding `idField`, `fieldsToColumns` and `tableName` will be required when your database tables do not follow the default naming conventions.++For example, if we have a database table `BOOK_TBL` with the following columns:++```sql+CREATE TABLE BOOK_TBL +  ( bookId INTEGER PRIMARY KEY, +    bookTitle TEXT, +    bookAuthor TEXT, +    bookYear INTEGER+  );+```+and we want to map this table to a Haskell data type `Book`:++```haskell+data Book = Book+  { book_id :: Int,+    title   :: String,+    author  :: String,+    year    :: Int+  }+  deriving (Generic, Show)+```++Then we can customize the default implementations of `idField`, `fieldsToColumns` and `tableName` to achieve the desired mapping:++```haskell+instance Entity Book where+  -- this is the primary key field of the Book data type (not following the default naming convention)+  idField = "book_id"++  -- this defines the mapping between the field names of the Book data type and the column names of the database table+  fieldsToColumns = [("book_id", "bookId"), ("title", "bookTitle"), ("author", "bookAuthor"), ("year", "bookYear")]++  -- this is the name of the database table+  tableName = "BOOK_TBL"+```++Overriding `fromRow` and `toRow` will be required when your database tables do not follow the default mapping conventions.+We will see some examples in later sections.+ ## Handling enumeration fields  Say we have a data type `Book` with an enumeration field of type `BookCategory`:@@ -161,31 +253,19 @@     year    :: Int,     category :: BookCategory   }-  deriving (Data, Show)+  deriving (Generic, Entity, Show)  data BookCategory = Fiction | Travel | Arts | Science | History | Biography | Other-  deriving (Data, Show, Enum)-```--In this case the `Entity` type class instance for `Book` has to be implemented manually, -as the automatic derivation of `Entity` does not cover this case (yet)--```haskell-instance Entity Book where-  fromRow row = return $ Book (col 0) (col 1) (col 2) (col 3) (col 4)-    where-      col i = fromSql (row !! i)--  toRow b = return [toSql (bookID b), toSql (title b), toSql (author b), toSql (year b), toSql (category b)]+  deriving (Generic, Show, Enum) ``` -`toSql` and `fromSql` expect `Convertible` instances as arguments. This works for `BookCatagory` as GenericPersistence provides `Convertible` instances for all `Enum` types.+In this case everything works out of the box, because *GenericPersistence* provides `Convertible` instances for all `Enum` types. `Convertible` instances are used to convert between Haskell types and database types. -If you do not want to use `Enum` types for your enumeration fields, you can implement `Convertible` instances for your own types:+If you do not want to use `Enum` types for your enumeration fields, you have to implement `Convertible` instances manually:  ```haskell data BookCategory = Fiction | Travel | Arts | Science | History | Biography | Other-  deriving (Data, Show, Read)+  deriving (Generic, Show, Read)  instance Convertible BookCategory SqlValue where   safeConvert = Right . toSql . show@@ -196,7 +276,7 @@  ## Handling embedded Objects -Say we have a data type `Article` with an field of type `Author`:+Say we have a data type `Article` with a field of type `Author`:  ```haskell data Article = Article@@ -205,14 +285,14 @@     author    :: Author,     year      :: Int   }-  deriving (Data, Show, Eq)+  deriving (Generic, Show, Eq)  data Author = Author   { authorID :: Int,     name     :: String,     address  :: String   }-  deriving (Data, Show, Eq)  +  deriving (Generic, Show, Eq)   ```  If we don't want to store the `Author` as a separate table, we can use the following approach to embed the `Author` into the `Article` table:@@ -221,26 +301,26 @@ instance Entity Article where   -- in the fields to column mapping we specify that all fields of the    -- Author type are also mapped to columns of the Article table:-  fieldsToColumns :: Article -> [(String, String)]-  fieldsToColumns _ = [("articleID", "articleID"),+  fieldsToColumns :: [(String, String)]+  fieldsToColumns = [("articleID", "articleID"),                        ("title", "title"),                         ("authorID", "authorID"),                         ("authorName", "authorName"),                         ("authorAddress", "authorAddress"),                        ("year", "year")-                      ]+                    ]    -- in fromRow we have to manually construct the Author object from the    -- respective columns of the Article table and insert it    -- into the Article object:-  fromRow row = return $ Article (col 0) (col 1) author (col 5)+  fromRow _conn row = return $ Article (col 0) (col 1) author (col 5)     where       col i = fromSql (row !! i)       author = Author (col 2) (col 3) (col 4)    -- in toRow we have to manually extract the fields of the Author object   -- and insert them into the respective columns of the Article table:-  toRow  a = return [toSql (articleID a), toSql (title a), toSql authID, toSql authorName, toSql authorAddress, toSql (year a)]+  toRow _conn a = return [toSql (articleID a), toSql (title a), toSql authID, toSql authorName, toSql authorAddress, toSql (year a)]     where        authID = authorID (author a)       authorName = name (author a)@@ -258,127 +338,153 @@     author    :: Author,     year      :: Int   }-  deriving (Data, Show, Eq)+  deriving (Generic, Show, Eq)  data Author = Author   { authorID :: Int,     name     :: String,     address  :: String   }-  deriving (Data, Entity, Show, Eq)  -- we derive Entity for Author+  deriving (Generic, Entity, Show, Eq) + instance Entity Article where-  -- in the fields to column mapping we specify an additional authorID field -  -- that will be used to store the id of the referenced Author object:-  fieldsToColumns :: Article -> [(String, String)]-  fieldsToColumns _ = [("articleID", "articleID"),-                       ("title", "title"), -                       ("authorID", "authorID"),-                       ("year", "year")-                      ]+  fieldsToColumns :: [(String, String)]                      -- ommitting the author field,+  fieldsToColumns =                                          -- as this can not be mapped to a single column+    [ ("articleID", "articleID"),                            -- instead we invent a new column authorID         +      ("title", "title"),+      ("authorID", "authorID"),+      ("year", "year")+    ] -  -- in fromRow we have to manually retrieve the Author object from the -  -- database (by using authorID as a foreign key)-  fromRow row = do-    maybeAuthor <- retrieveById (row !! 2) :: GP (Maybe Author)-    let author = fromJust maybeAuthor-    pure $ Article (col 0) (col 1) author (col 3)+  fromRow :: Conn -> [SqlValue] -> IO Article+  fromRow conn row = do    +    authorById <- fromJust <$> retrieveById conn (row !! 2)  -- load author by foreign key+    return $ rawArticle {author = authorById}                -- add author to article     where-      col i = fromSql (row !! i)--  -- in toRow we have manually persist the Author object and include-  -- the authorID of the Author object in the Article row:    -  toRow a = do -    persist (author a)-    return [toSql (articleID a), toSql (title a), toSql $ authorID (author a), toSql (year a)]+      rawArticle = Article (col 0) (col 1)                   -- create article from row, +                           (Author (col 2) "" "") (col 3)    -- using a dummy author+        where+          col i = fromSql (row !! i) +  toRow :: Conn -> Article -> IO [SqlValue]+  toRow conn a = do+    persist conn (author a)                                  -- persist author first+    return [toSql (articleID a), toSql (title a),            -- return row for article table where +            toSql $ authorID (author a), toSql (year a)]     -- authorID is foreign key to author table  ```++Persisting the `Author`as a side effect in `toRow` may sound like an *interesting* idea...+This step is optional. But then the user has to make sure that the `Author` is persisted before the `Article` is persisted.++ ## Handling 1:n references -Now let's extend the previous example by also having a list of Àrticle`s in the `Author` type:+Now let's change the previous example by having a list of Articles in the `Author` type:  ```haskell-data Article = Article-  { articleID :: Int,-    title     :: String,-    author    :: Author,-    year      :: Int-  }-  deriving (Data, Show, Eq)- data Author = Author   { authorID :: Int,     name     :: String,     address  :: String,     articles :: [Article]   }-  deriving (Data, Show, Eq)  -```--So now we have a 1:n relationship between `Author` and `Article`. And in addtion we have the 1:1 relationship between `Article` and `Author` that we have seen in the previous example.+  deriving (Generic, Show, Eq) -This situation is a bit more complicated, as we have to handle relationships between `Article` and `Author` at the same time. And we have to make sure that we don't end up in an infinite loop when we persist an `Author` object that contains a list of `Article` objects that in turn contain the same `Author` object. +data Article = Article+  { articleID :: Int,+    title     :: String,+    authorId  :: Int,+    year      :: Int+  }+  deriving (Generic, Entity, Show, Eq)+``` -The same problem occurs when we retrieve an `Author` object that contains a list of `Article` objects that in turn contain the same `Author` object.+So now we have a `1:n` relationship between `Author` and `Article`.  -We can handle this situation by using the following approach:+We can handle this situation by using the following instance declaration for `Author`:  ```haskell-instance Entity Article where-  -- in the fields to column mapping we specify an additional authorID field:-  fieldsToColumns :: Article -> [(String, String)]-  fieldsToColumns _ = [("articleID", "articleID"),-                       ("title", "title"), -                       ("authorID", "authorID"),-                       ("year", "year")-                      ]+instance Entity Author where+  fieldsToColumns :: [(String, String)]                   -- ommitting the articles field, +  fieldsToColumns =                                       -- as this can not be mapped to a single column+    [ ("authorID", "authorID"),+      ("name", "name"),+      ("address", "address")+    ] -  -- in fromRow we have to take care that we don't end up in an infinite loop-  -- so we first place a dummy Article object into the cache and then-  -- retrieve the Author object either from cache or from the db:-  fromRow :: [SqlValue] -> GP Article-  fromRow row = local (extendCtxCache rawArticle) $ do-    maybeAuthor <- getElseRetrieve (entityId rawAuthor)-    let author = fromJust maybeAuthor-    pure $ Article (col 0) (col 1) author (col 3)+  fromRow :: Conn -> [SqlValue] -> IO Author+  fromRow conn row = do+    let authID = head row                                 -- authorID is the first column+    articlesBy <- retrieveAllWhere conn "authorId" authID -- retrieve all articles by this author+    return rawAuthor {articles = articlesBy}              -- add the articles to the author     where-      col i = fromSql (row !! i)-      rawAuthor = (evidence :: Author) {authorID = col 2}-      rawArticle = Article (col 0) (col 1) rawAuthor (col 3)-    -  toRow a = do -    persist (author a)-    return [toSql (articleID a), toSql (title a), toSql $ authorID (author a), toSql (year a)]+      rawAuthor = Author (col 0) (col 1) (col 2) []       -- create the author from row (w/o articles)+      col i = fromSql (row !! i)                          -- helper function to convert SqlValue to Haskell type +  toRow :: Conn -> Author -> IO [SqlValue]+  toRow conn a = do+    mapM_ (persist conn) (articles a)                     -- persist all articles of this author (update or insert)+    return [toSql (authorID a),                           -- return the author as a list of SqlValues+            toSql (name a), toSql (address a)]+``` -instance Entity Author where-  -- in the fields to column mapping we have anything for the articles field:-  fieldsToColumns :: Author -> [(String, String)]-  fieldsToColumns _ = [("authorID", "authorID"),-                       ("name", "name"), -                       ("address", "address")-                      ]+Persisting all articles of an author as a side effect during the conversion of the author to a row may seem *special*...+You can ommit this step. But then you have to persist the articles manually before persisting the author. -  -- in fromRow we have to take care that we don't end up in an infinite loop.-  -- So we first place a dummy Author object into the cache and then-  -- retrieve matching list of  Article objects (from cache or from the db):-  fromRow :: [SqlValue] -> GP Author-  fromRow row = local (extendCtxCache rawAuthor) $ do-    articlesByAuth <- retrieveAllWhere (idField rawAuthor) (idValue rawAuthor) :: GP [Article]-    pure $ rawAuthor {articles= articlesByAuth}-    where-      col i = fromSql (row !! i)-      rawAuthor = Author (col 0) (col 1) (col 2) []+## Integrating user defined queries -  -- in toRow we do not safe the articles field to avoid infinite loops:-  toRow :: Author -> GP [SqlValue]-  toRow a = do -    return [toSql (authorID a), toSql (name a), toSql (address a)]+As of now, the library only supports very basic support for queries:++- `retrieveById` retrieves a single row of a table by its primary key+- `retrieveAll` retrieves all rows of a table+- `retrieveAllWhere` retrieves all rows of a table where a given column has a given value++If you want to use more complex queries, you can integrate HDBC SQL queries by using the `entitiesFromRows` function as in the following example:++```haskell+main :: IO ()+main = do+  -- connect to a database+  conn <- connect SQLite <$> connectSqlite3 ":memory:" ++  -- initialize Person table+  setupTableFor @Person conn++  let alice = Person 1 "Alice" 25 "123 Main St"+      bob = Person 2 "Bob" 30 "456 Elm St"+      charlie = Person 3 "Charlie" 35 "789 Pine St"+      dave = Person 4 "Dave" 40 "1011 Oak St"+      eve = Person 5 "Eve" 45 "1213 Maple St"+      frank = Person 6 "Frank" 50 "1415 Walnut St"+      people = [alice, bob, charlie, dave, eve, frank]+      +  -- insert all persons into the database+  insertMany conn people++  -- perform a custom query with HDBC+  stmt = "SELECT * FROM Person WHERE age >= ?"+  resultRows <- quickQuery conn stmt [toSql (40 :: Int)]++  -- convert the resulting rows into a list of Person objects+  fourtplussers <- entitiesFromRows @Person conn resultRows+  print fourtplussers ``` -## Todo+Of course this approach is not type safe. It is up to the user to make sure that the query returns the correct columns.  -- coding free support for 1:1 and 1:n relationships-- coding free support for Enums-- resolution cache with proper Map+## The `Conn` Connection Type++The `Conn` type is a wrapper around an `IConnection` obtained from an HDBC backend driver like `HDBC-sqlite3` or `hdbc-postgresql`. It is used to pass the connection to the database to *Generic-Persistence*. All functions of the library that require a database connection take a `Conn` as an argument.++HDBC provides a very similar type called `ConnectionWrapper`. The main reason for such a wrapper type is to simplify the type signatures of the library functions. ++In addition, the `Conn` type provides additional database related information that is not available in the `ConnectionWrapper` type. For example, the `Conn` type contains the name of the database driver that is used. This information can be used to generate the correct SQL statements for different database backends.+`Conn` also carries a flag that indicates whether implicit commits should be used by the library. This flag is set to `True` by default. If you want to use explicit commits, you can set the flag to `False` by modifying the `Conn` value:+  +```haskell+c <- connect SQLite <$> connectSqlite3 ":memory:"+let conn = c {implicitCommit = False}+```+ 

@@ -1,15 +1,12 @@ -- allows automatic derivation from Entity type class {-# LANGUAGE DeriveAnyClass #-} -module Main (main, main1) where+module Main (main, main1, main2, main3) where -import           Data.Data             (Data)-import           Database.GP           (Entity (..), GP, delete, insert, liftIO,-                                        persist, retrieveAll, retrieveById,-                                        runGP, setupTableFor, update)-import           Database.HDBC         (IConnection (disconnect), fromSql,-                                        toSql)-import           Database.HDBC.Sqlite3 (connectSqlite3)+import           Database.GP         +import           Database.HDBC+import           Database.HDBC.Sqlite3+import           GHC.Generics  -- | An Entity data type with several fields, using record syntax. data Person = Person@@ -18,7 +15,7 @@     age      :: Int,     address  :: String   }-  deriving (Data, Entity, Show) -- deriving Entity allows to handle the type with GenericPersistence+  deriving (Generic, Entity, Show) -- deriving Entity allows to handle the type with GenericPersistence  data Book = Book   { book_id :: Int,@@ -26,76 +23,59 @@     author  :: String,     year    :: Int   }-  deriving (Data, Show) -- no auto deriving of Entity, so we have to implement the Entity type class:+  deriving (Generic, Show) -- no auto deriving of Entity, so we have to implement the Entity type class:  instance Entity Book where   -- this is the primary key field of the Book data type-  idField _ = "book_id"+  idField = "book_id"    -- this defines the mapping between the field names of the Book data type and the column names of the database table-  fieldsToColumns _ = [("book_id", "bookId"), ("title", "bookTitle"), ("author", "bookAuthor"), ("year", "bookYear")]+  fieldsToColumns = [("book_id", "bookId"), ("title", "bookTitle"), ("author", "bookAuthor"), ("year", "bookYear")]    -- this is the name of the database table-  tableName _ = "BOOK_TBL"+  tableName = "BOOK_TBL" -  -- this is the function that converts a row from the database table into a Book data type-  fromRow row = return $ Book (col 0) (col 1) (col 2) (col 3)-    where-      col i = fromSql (row !! i)+  -- -- this is the function that converts a row from the database table into a Book data type+  -- fromRow _c row = return $ Book (col 0) (col 1) (col 2) (col 3)+  --   where+  --     col i = fromSql (row !! i) -  -- this is the function that converts a Book data type into a row for the database table-  toRow b = return [toSql (book_id b), toSql (title b), toSql (author b), toSql (year b)]+  -- -- this is the function that converts a Book data type into a row for the database table+  -- toRow _c b = return [toSql (book_id b), toSql (title b), toSql (author b), toSql (year b)]  main :: IO () main = do   -- connect to a database-  conn <- connectSqlite3 "sqlite.db"-  -- take the connection and execute all persistence operations in the GP monad (type alias for RIO Ctx)-  runGP conn $ do-    _ <- setupTableFor :: GP Person-    _ <- setupTableFor :: GP Book--    let alice = Person 123456 "Alice" 25 "123 Main St"-        book = Book 1 "The Hobbit" "J.R.R. Tolkien" 1937--    -- insert a Person into the database (persist will either insert or update)-    persist alice--    -- insert a second Person-    persist alice {personID = 123457, name = "Bob"}--    -- update a Person-    persist alice {address = "Elmstreet 1"}+  conn <- connect SQLite <$> connectSqlite3 "sqlite.db" -    -- select a Person from a database-    alice' <- retrieveById (123456 :: Int) :: GP (Maybe Person)-    liftIO $ print alice'+  -- initialize Person table+  setupTableFor @Person conn -    -- select all Persons from the database-    allPersons <- retrieveAll :: GP [Person]-    liftIO $ print allPersons+  -- create a Person entity+  let alice = Person {personID = 123456, name = "Alice", age = 25, address = "Elmstreet 1"} -    -- delete a Person-    delete alice+  -- insert a Person into a database+  insert conn alice -    -- select all Persons from a database. The deleted Person is not in the result.-    allPersons' <- retrieveAll :: GP [Person]-    liftIO $ print allPersons'+  -- update a Person+  update conn alice {address = "Main Street 200"} -    let book2 = Book {book_id = 2, title = "The Lord of the Ring", author = "J.R.R. Tolkien", year = 1954}+  -- select a Person from a database+  -- The result type must be provided by the call site, +  -- as `retrieveEntityById` has a polymorphic return type `IO (Maybe a)`.+  alice' <- retrieveById @Person conn "123456" +  print alice' -    -- this time we are using insert directly-    insert book-    insert book2-    allBooks <- retrieveAll :: GP [Book]-    liftIO $ print allBooks+  -- select all Persons from a database+  allPersons <- retrieveAll @Person conn+  print allPersons -    -- explicitly updating a Book-    update book2 {title = "The Lord of the Rings"}-    delete book+  -- delete a Person from a database+  delete conn alice -    allBooks' <- retrieveAll :: GP [Book]-    liftIO $ print allBooks'+  -- select all Persons from a database. Now it should be empty.+  allPersons' <- retrieveAll conn :: IO [Person]+  print allPersons'    -- close connection   disconnect conn@@ -103,31 +83,103 @@ main1 :: IO () main1 = do   -- connect to a database-  conn <- connectSqlite3 "sqlite.db"-  runGP conn $ do-    -- initialize Person table-    _ <- setupTableFor :: GP Person+  conn <- Conn SQLite False <$> connectSqlite3 "test.db" -- ":memory:"  -    -- create a Person entity-    let alice = Person {personID = 123456, name = "Alice", age = 25, address = "Elmstreet 1"}+  -- initialize Person and Book tables+  setupTableFor @Person conn+  setupTableFor @Book conn -    -- insert a Person into a database-    persist alice+  let alice = Person 123456 "Alice" 25 "123 Main St"+      book = Book 1 "The Hobbit" "J.R.R. Tolkien" 1937 -    -- update a Person-    persist alice {address = "Main Street 200"}+  -- insert a Person into the database (persist will either insert or update)+  persist conn alice -    -- select a Person from a database-    -- The result type must be provided explicitly, as `retrieveEntityById` has a polymorphic return type `IO a`.-    alice' <- retrieveById "123456" :: GP (Maybe Person)-    liftIO $ print alice'+  -- insert a second Person+  persist conn alice {personID = 123457, name = "Bob"} -    alice'' <- retrieveById "123456" :: GP (Maybe Person)+  -- update a Person+  persist conn alice {address = "Elmstreet 1"} -    liftIO $ print alice''+  -- select a Person from a database+  alice' <- retrieveById conn (123456 :: Int) :: IO (Maybe Person)+  print alice' -    -- delete a Person from a database-    delete alice+  -- select all Persons from the database+  allPersons <- retrieveAll conn :: IO [Person]+  print allPersons +  -- delete a Person+  delete conn alice++  -- select all Persons from a database. The deleted Person is not in the result.+  allPersons' <- retrieveAll conn :: IO [Person]+  print allPersons'++  let book2 = Book {book_id = 2, title = "The Lord of the Ring", author = "J.R.R. Tolkien", year = 1954}++  -- this time we are using insert directly+  insert conn book+  insert conn book2+  allBooks <- retrieveAll conn :: IO [Book]+  print allBooks++  -- explicitly updating a Book+  update conn book2 {title = "The Lord of the Rings"}+  delete conn book++  allBooks' <- retrieveAll conn :: IO [Book]+  print allBooks'+   -- close connection   disconnect conn+++main2 :: IO ()+main2 = do+  -- connect to a database+  conn <- connect SQLite <$> connectSqlite3 ":memory:" ++  -- initialize Person table+  setupTableFor @Person conn++  let alice = Person 1 "Alice" 25 "123 Main St"+      bob = Person 2 "Bob" 30 "456 Elm St"+      charlie = Person 3 "Charlie" 35 "789 Pine St"+      dave = Person 4 "Dave" 40 "1011 Oak St"+      eve = Person 5 "Eve" 45 "1213 Maple St"+      frank = Person 6 "Frank" 50 "1415 Walnut St"+      people = [alice, bob, charlie, dave, eve, frank]+      stmt = "SELECT * FROM Person WHERE age >= ?"++  -- insert all persons into the database+  insertMany conn people++  -- select all Person with age >= 40+  resultRows <- quickQuery conn stmt [toSql (40 :: Int)]+  fourtplussers <- entitiesFromRows @Person conn resultRows+  print fourtplussers+  +main3 :: IO ()+main3 = do+  -- connect to a database+  conn <- connect SQLite <$> connectSqlite3 "test.db" ++  -- initialize Person table+  setupTableFor @Person conn++  let alice = Person 1 "Alice" 25 "123 Main St"+      bob = Person 2 "Bob" 30 "456 Elm St"+      charlie = Person 3 "Charlie" 35 "789 Pine St"+      dave = Person 4 "Dave" 40 "1011 Oak St"+      eve = Person 5 "Eve" 45 "1213 Maple St"+      frank = Person 6 "Frank" 50 "1415 Walnut St"+      people = [alice, bob, charlie, dave, eve, frank]++  -- insert all persons into the database+  insertMany conn people  ++  people' <- retrieveAll @Person conn+  print $ length people'++

@@ -1,12 +1,12 @@ cabal-version:      1.12 name:               generic-persistence-version:            0.2.0.1+version:            0.3.0.0 license:            BSD3 license-file:       LICENSE copyright:          2023 Thomas Mahler maintainer:         thma@apache.org author:             Thomas Mahler-tested-with:        ghc ==9.2.5 ghc ==9.0.2 ghc ==8.10.7+tested-with:        ghc ==9.2.5 ghc ==9.4.4 homepage:           https://github.com/thma/generic-persistence#readme bug-reports:        https://github.com/thma/generic-persistence/issues synopsis:           Database persistence using generics@@ -24,9 +24,9 @@ library     exposed-modules:         Database.GP+        Database.GP.Conn         Database.GP.Entity         Database.GP.GenericPersistence-        Database.GP.RecordtypeReflection         Database.GP.SqlGenerator         Database.GP.TypeInfo @@ -40,18 +40,9 @@      build-depends:         HDBC <2.5,-        HDBC-sqlite3 <2.4,         base >=4.7 && <5,-        bytestring <0.12,         convertible <1.2,-        exceptions <0.11,-        ghc <9.3,-        ghc-prim <0.9,-        rio <0.2,-        syb <0.8,-        text <1.3,-        time <1.12,-        transformers <0.6+        generic-deriving <1.15  executable generic-persistence-demo     main-is:          Main.hs@@ -68,17 +59,9 @@         HDBC <2.5,         HDBC-sqlite3 <2.4,         base >=4.7 && <5,-        bytestring <0.12,         convertible <1.2,-        exceptions <0.11,-        generic-persistence,-        ghc <9.3,-        ghc-prim <0.9,-        rio <0.2,-        syb <0.8,-        text <1.3,-        time <1.12,-        transformers <0.6+        generic-deriving <1.15,+        generic-persistence  test-suite generic-persistence-test     type:               exitcode-stdio-1.0@@ -105,16 +88,8 @@         HDBC-sqlite3 <2.4,         QuickCheck <2.15,         base >=4.7 && <5,-        bytestring <0.12,         convertible <1.2,-        exceptions <0.11,+        generic-deriving <1.15,         generic-persistence,-        ghc <9.3,-        ghc-prim <0.9,         hspec <2.10,-        hspec-discover <2.10,-        rio <0.2,-        syb <0.8,-        text <1.3,-        time <1.12,-        transformers <0.6+        hspec-discover <2.10

@@ -1,37 +1,31 @@-module Database.GP   ( retrieveById,+module Database.GP+  ( retrieveById,     retrieveAll,     retrieveAllWhere,+    entitiesFromRows,     persist,     insert,+    insertMany,     update,+    updateMany,     delete,     setupTableFor,     idValue,     Entity (..),+    GToRow,+    GFromRow,     columnNameFor,-    fieldTypeFor,     maybeFieldTypeFor,     toString,-    evidence,-    evidenceFrom,-    ResolutionCache,     EntityId,     entityId,-    getElseRetrieve,     TypeInfo (..),-    typeInfoFromContext,     typeInfo,-    Ctx (..),-    GP,-    extendCtxCache,-    runGP,-    liftIO,-    local,-    ask,+    Conn (..),+    Database (..),+    connect,   ) where --- We are just re-exporting the functions from the GenericPersistence module.  +-- We are just re-exporting from the GenericPersistence module. import           Database.GP.GenericPersistence--

@@ -0,0 +1,61 @@+module Database.GP.Conn+  ( Conn (..),+    connect,+    Database (..),+  )+where++import           Control.Monad ((>=>))+import           Database.HDBC hiding (withWConn)++{--+  This module defines a wrapper around an HDBC IConnection. Using this wrapper `Conn` simplifies the signature of the functions in the `Database.GP` module.+  It allows to use any HDBC connection without having to define a new function for each connection type.+  It also provides additional attributes to the connection, like the database type and the implicit commit flag.+  These attributes can be used to implement database specific functionality, modify transaction behaviour, etc.++  This code has been inspired by the HDBC ConnectionWrapper and some parts have been copied from the HDBC Database.HDBC.Types module.+--}++-- | A wrapper around an HDBC IConnection.+data Conn = forall conn.+  IConnection conn =>+  Conn+  { -- | The database type+    db             :: Database,+    -- | If True, the GenericPersistence functions will commit the transaction after each operation.+    implicitCommit :: Bool,+    -- | The wrapped connection+    connection     :: conn+  }++-- | An enumeration of the supported database types.+data Database = Postgres | MySQL | SQLite | Oracle | MSSQL+  deriving (Show, Eq, Enum)++-- | a smart constructor for the Conn type.+connect :: forall conn. IConnection conn => Database -> conn -> Conn+connect db = Conn db True++-- | allows to execute a function that requires an `IConnection` argument on a `Conn`.      +withWConn :: forall b. Conn -> (forall conn. IConnection conn => conn -> b) -> b+withWConn (Conn _db _ic conn) f = f conn+    ++-- | manually implement the IConnection type class for the Conn type.+instance IConnection Conn where+  disconnect w = withWConn w disconnect+  commit w = withWConn w commit+  rollback w = withWConn w rollback+  runRaw w = withWConn w runRaw+  run w = withWConn w run+  prepare w = withWConn w prepare+  clone w@(Conn db ic _) = withWConn w (clone >=> return . Conn db ic)+  hdbcDriverName w = withWConn w hdbcDriverName+  hdbcClientVer w = withWConn w hdbcClientVer+  proxiedClientName w = withWConn w proxiedClientName+  proxiedClientVer w = withWConn w proxiedClientVer+  dbServerVer w = withWConn w dbServerVer+  dbTransactionSupport w = withWConn w dbTransactionSupport+  getTables w = withWConn w getTables+  describeTable w = withWConn w describeTable

@@ -1,42 +1,50 @@-{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE AllowAmbiguousTypes  #-}+{-# LANGUAGE DataKinds            #-}+{-# LANGUAGE DefaultSignatures    #-}+{-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE TypeOperators        #-}+{-# LANGUAGE UndecidableInstances #-}  module Database.GP.Entity   ( Entity (..),     columnNameFor,-    fieldTypeFor,-    maybeFieldTypeFor,     toString,-    evidence,-    evidenceFrom,-    ResolutionCache,     EntityId,-    Ctx (..),-    GP,+    gtoRow,+    GToRow,+    GFromRow,+    maybeFieldTypeFor,+    Conn(..),+    Database(..),   ) where  import           Data.Char            (toLower)-import           Data.Data            -import           Database.HDBC        (SqlValue, fromSql, ConnWrapper)-import           Database.GP.RecordtypeReflection (gFromRow, gToRow)-import           Database.GP.TypeInfo             -import           Data.Dynamic-import           RIO+import           Data.Convertible+import           Data.Kind+import           Data.Typeable        (Proxy (..), TypeRep)+import           Database.GP.TypeInfo+import           Database.HDBC        (SqlValue)+import           GHC.Generics+import           GHC.TypeNats+import           Generics.Deriving.Show (GShow' (..), gshowsPrecdefault)+import           Database.GP.Conn  {---This is the Entity class. It is a type class that is used to define the mapping +This is the Entity class. It is a type class that is used to define the mapping between a Haskell product type in record notation and a database table.-The class has a default implementation for all methods. +The class has a default implementation for all methods. The default implementation uses the type information to determine a simple 1:1 mapping. -That means that -- the type name is used as the table name and the +That means that+- the type name is used as the table name and the - field names are used as the column names. - A field named '<lowercase typeName>ID' is used as the primary key field.  The default implementation can be overridden by defining a custom instance for a type. -Please note the following constraints, which apply to all valid Entity type, +Please note the following constraints, which apply to all valid Entity type, but that are not explicitely encoded in the type class definition:  - The type must be a product type in record notation.@@ -45,102 +53,128 @@  --} -class (Data a) => Entity a where++class (Generic a, HasConstructor (Rep a), HasSelectors (Rep a)) => Entity a where   -- | Converts a database row to a value of type 'a'.-  fromRow :: [SqlValue] -> GP a+  fromRow :: Conn -> [SqlValue] -> IO a    -- | Converts a value of type 'a' to a database row.-  toRow :: a -> GP [SqlValue]+  toRow :: Conn -> a -> IO [SqlValue]    -- | Returns the name of the primary key field for a type 'a'.-  idField :: a -> String+  idField :: String    -- | Returns a list of tuples that map field names to column names for a type 'a'.-  fieldsToColumns :: a -> [(String, String)]+  fieldsToColumns :: [(String, String)]    -- | Returns the name of the table for a type 'a'.-  tableName :: a -> String+  tableName :: String -  -- | generic default implementation-  default fromRow :: [SqlValue] -> GP a-  fromRow = pure . gFromRow+  -- | fromRow generic default implementation+  default fromRow :: (GFromRow (Rep a)) => Conn -> [SqlValue] -> IO a+  fromRow _conn = pure . to <$> gfromRow -  -- | generic default implementation-  default toRow :: a -> GP [SqlValue]-  toRow = pure . gToRow+  -- | toRow generic default implementation+  default toRow :: GToRow (Rep a) => Conn -> a -> IO [SqlValue]+  toRow _ = pure . gtoRow . from -  -- | default implementation: the ID field is the field with the same name+  -- | idField default implementation: the ID field is the field with the same name   --   as the type name in lower case and appended with "ID", e.g. "bookID"-  default idField :: a -> String-  idField = idFieldName . typeInfo+  default idField :: String+  idField = idFieldName     where-      idFieldName :: TypeInfo a -> String-      idFieldName ti = map toLower (typeName ti) ++ "ID"--  -- | default implementation: the field names are used as column names-  default fieldsToColumns :: a -> [(String, String)]-  fieldsToColumns x = zip (fieldNames (typeInfo x)) (fieldNames (typeInfo x))--  -- | default implementation: the type name is used as table name-  default tableName :: a -> String-  tableName = typeName . typeInfo---- | type Ctx defines the context in which the persistence operations are executed.--- It contains a connection to the database and a resolution cache for circular lookups.-data Ctx = -  Ctx-    {connection :: ConnWrapper,-     cache :: ResolutionCache-    }+      idFieldName :: String+      idFieldName = map toLower (constructorName ti) ++ "ID"+      ti = typeInfo @a -type GP = RIO Ctx+  -- | fieldsToColumns default implementation: the field names are used as column names+  default fieldsToColumns :: [(String, String)]+  fieldsToColumns = zip (fieldNames (typeInfo @a)) (fieldNames (typeInfo @a)) --- | The EntityId is a tuple of the TypeRep and the primary key value of an Entity.---   It is used as a key in the resolution cache.-type EntityId = (TypeRep, SqlValue)+  -- | tableName default implementation: the type name is used as table name+  default tableName :: String+  tableName = constructorName ti+    where+      ti = typeInfo @a --- | The resolution cache maps an EntityId to a Dynamic value (representing an Entity).---   It is used to resolve circular references during loading and storing of Entities.-type ResolutionCache = [(EntityId, Dynamic)]+-- | The EntityId is a tuple of the constructor name and the primary key value of an Entity.+type EntityId = (String, SqlValue)  -- | A convenience function: returns the name of the column for a field of a type 'a'.-columnNameFor :: Entity a => a -> String -> String-columnNameFor x fieldName =-  case maybeColumnNameFor x fieldName of+columnNameFor :: forall a. (Entity a) => String -> String+columnNameFor fieldName =+  case maybeColumnNameFor fieldName of     Just columnName -> columnName-    Nothing -> error ("columnNameFor: " ++ toString x ++ -                      " has no column mapping for " ++ fieldName)+    Nothing ->+      error+        ( "columnNameFor: "+            ++ tableName @a+            ++ " has no column mapping for "+            ++ fieldName+        )   where-    maybeColumnNameFor :: Entity a => a -> String -> Maybe String-    maybeColumnNameFor a field = lookup field (fieldsToColumns a)---- | A convenience function: returns the TypeRep of a field of a type 'a'.  -fieldTypeFor :: Entity a => a -> String -> TypeRep-fieldTypeFor x fieldName =-  case maybeFieldTypeFor x fieldName of-    Just tyRep -> tyRep-    Nothing -> error ("fieldTypeFor: " ++ toString x ++ -                      " has no field " ++ fieldName)+    maybeColumnNameFor :: String -> Maybe String+    maybeColumnNameFor field = lookup field (fieldsToColumns @a) -maybeFieldTypeFor :: Entity a => a -> String -> Maybe TypeRep-maybeFieldTypeFor a field = lookup field (fieldsAndTypes (typeInfo a))+maybeFieldTypeFor :: forall a. (Entity a) => String -> Maybe TypeRep+maybeFieldTypeFor field = lookup field (fieldsAndTypes (typeInfo @a))   where     fieldsAndTypes :: TypeInfo a -> [(String, TypeRep)]     fieldsAndTypes ti = zip (fieldNames ti) (fieldTypes ti)  -- | Returns a string representation of a value of type 'a'.-toString :: (Entity a) => a -> String-toString x = typeName (typeInfo x) ++ " " ++ unwords mappedRow+toString :: forall a. (Generic a, GShow' (Rep a)) => a -> String+toString = gshow   where-    mappedRow = map fromSql (gToRow x)+    gshows :: a -> ShowS+    gshows = gshowsPrecdefault 0 --- | A convenience function: returns an evidence instance of type 'a'.---   This is useful for type inference where no instance is available.-evidence :: forall a. (Entity a) => a -evidence = evidenceFrom ti-  where -    ti = typeInfoFromContext :: TypeInfo a+    gshow :: a -> String+    gshow x = gshows x "" +-- generics based implementations for gFromRow and gToRow+-- toRow+class GToRow f where+  gtoRow :: f a -> [SqlValue] -evidenceFrom :: forall a. (Entity a) => TypeInfo a -> a-evidenceFrom = fromConstr . typeConstructor+instance GToRow U1 where+  gtoRow U1 = mempty++instance (Convertible a SqlValue) => GToRow (K1 i a) where+  gtoRow (K1 a) = pure $ convert a++instance (GToRow a, GToRow b) => GToRow (a :*: b) where+  gtoRow (a :*: b) = gtoRow a `mappend` gtoRow b++instance GToRow a => GToRow (M1 i c a) where+  gtoRow (M1 a) = gtoRow a++-- fromRow+class GFromRow f where+  gfromRow :: [SqlValue] -> f a++instance GFromRow U1 where+  gfromRow = pure U1++instance (Convertible SqlValue a) => GFromRow (K1 i a) where+  gfromRow = K1 <$> convert . head++instance GFromRow a => GFromRow (M1 i c a) where+  gfromRow = M1 <$> gfromRow++-- | This instance is the most interesting one. It splits the list of+-- 'SqlValue's into two parts, one for the first field and one for the+-- rest. Then it uses the 'GFromRow' instance for the first field to+-- convert the first part of the list and the 'GFromRow' instance for+-- the rest of the fields to convert the second part of the list.+-- Finally, it combines the two results using the ':*:' constructor.+-- https://stackoverflow.com/questions/75485429/how-to-use-ghc-generics-to-convert-from-product-data-types-to-a-list-of-sqlvalue/75485650#75485650+instance (KnownNat (NumFields f), GFromRow f, GFromRow g) => GFromRow (f :*: g) where+  gfromRow row = gfromRow rowf :*: gfromRow rowg+    where+      (rowf, rowg) = splitAt fNumFields row+      fNumFields = fromIntegral (natVal (Proxy :: Proxy (NumFields f)))++type family NumFields (f :: Type -> Type) :: Nat where+  NumFields (M1 i c f) = 1+  NumFields (f :*: g) = NumFields f + NumFields g

@@ -1,48 +1,44 @@+{-# LANGUAGE AllowAmbiguousTypes #-} {-# OPTIONS_GHC -Wno-orphans #-}+ module Database.GP.GenericPersistence   ( retrieveById,     retrieveAll,     retrieveAllWhere,+    entitiesFromRows,     persist,     insert,+    insertMany,     update,+    updateMany,     delete,     setupTableFor,     idValue,+    Conn(..),+    connect,+    Database(..),     Entity (..),+    GToRow,+    GFromRow,     columnNameFor,-    fieldTypeFor,     maybeFieldTypeFor,     toString,-    evidence,-    evidenceFrom,-    ResolutionCache,     EntityId,     entityId,-    getElseRetrieve,     TypeInfo (..),-    typeInfoFromContext,     typeInfo,-    Ctx (..),-    GP,-    extendCtxCache,-    runGP,-    liftIO,-    local,-    ask,   ) where -import Data.Convertible ( Convertible, ConvertResult )-import           Database.HDBC        +import           Data.Convertible         (ConvertResult, Convertible)+import           Data.Convertible.Base    (Convertible (safeConvert))+import           Data.List                (elemIndex)+import           Database.GP.Conn import           Database.GP.Entity-import           Database.GP.RecordtypeReflection import           Database.GP.SqlGenerator import           Database.GP.TypeInfo-import           Data.Dynamic (toDyn, fromDynamic)-import           Data.Data -import Data.Convertible.Base (Convertible(safeConvert))-import           RIO+import           Database.HDBC+import Control.Monad (when)  {--  This module defines RDBMS Persistence operations for Record Data Types that are instances of 'Data'.@@ -52,142 +48,157 @@  HDBC is used to access the RDBMS. --} --- -- | A function that retrieves an entity from a database. -- The function takes entity id as parameter. -- If an entity with the given id exists in the database, it is returned as a Just value. -- If no such entity exists, Nothing is returned. -- An error is thrown if there are more than one entity with the given id.-retrieveById :: forall a id. (Entity a, Convertible id SqlValue) => id -> GP (Maybe a)-retrieveById idx = do-  conn <- askConnection-  resultRowsSqlValues <- liftIO $ quickQuery conn stmt [eid]+retrieveById :: forall a id. (Entity a, Convertible id SqlValue) => Conn -> id -> IO (Maybe a)+retrieveById conn idx = do+  resultRowsSqlValues <- quickQuery conn stmt [eid]   case resultRowsSqlValues of-    []          -> pure Nothing-    [singleRow] -> Just <$> fromRow singleRow-    _ -> error $ "More than one" ++ show (typeConstructor ti) ++ " found for id " ++ show eid+    [] -> pure Nothing+    [singleRow] -> Just <$> fromRow conn singleRow+    _ -> error $ "More than one" ++ constructorName ti ++ " found for id " ++ show eid   where-    ti = typeInfoFromContext :: TypeInfo a-    stmt = selectStmtFor ti+    ti = typeInfo @a+    stmt = selectStmtFor @a     eid = toSql idx - -- | This function retrieves all entities of type `a` from a database. --  The function takes an HDBC connection as parameter. --  The type `a` is determined by the context of the function call.-retrieveAll :: forall a. (Entity a) => GP [a]-retrieveAll = do-  conn <- askConnection-  resultRows <- liftIO $ quickQuery conn stmt []-  mapM fromRow resultRows+retrieveAll :: forall a. (Entity a) => Conn -> IO [a]+retrieveAll conn = do+  resultRows <- quickQuery conn stmt []+  entitiesFromRows conn resultRows   where-    ti = typeInfoFromContext :: TypeInfo a-    stmt = selectAllStmtFor ti +    stmt = selectAllStmtFor @a -retrieveAllWhere :: forall a. (Entity a) => String -> SqlValue -> GP [a]-retrieveAllWhere field val = do-  conn <- askConnection-  resultRows <- liftIO $ quickQuery conn stmt [val]-  mapM fromRow resultRows+-- | This function retrieves all entities of type `a` where a given field has a given value.+--  The function takes an HDBC connection, the name of the field and the value as parameters.+--  The type `a` is determined by the context of the function call.+--  The function returns a (possibly empty) list of all matching entities.+retrieveAllWhere :: forall a. (Entity a) => Conn -> String -> SqlValue -> IO [a]+retrieveAllWhere conn field val = do+  resultRows <- quickQuery conn stmt [val]+  entitiesFromRows conn resultRows   where-    ti = typeInfoFromContext :: TypeInfo a-    stmt = selectAllWhereStmtFor ti field+    stmt = selectAllWhereStmtFor @a field +-- | This function converts a list of database rows, represented as a `[[SqlValue]]` to a list of entities.+--   The function takes an HDBC connection and a list of database rows as parameters.+--   The type `a` is determined by the context of the function call.+--   The function returns a (possibly empty) list of all matching entities.+--   The function is used internally by `retrieveAll` and `retrieveAllWhere`.+--   But it can also be used to convert the result of a custom SQL query to a list of entities.+entitiesFromRows :: forall a. (Entity a) => Conn -> [[SqlValue]] -> IO [a]+entitiesFromRows = mapM . fromRow+ -- | A function that persists an entity to a database. -- The function takes an HDBC connection and an entity as parameters. -- The entity is either inserted or updated, depending on whether it already exists in the database. -- The required SQL statements are generated dynamically using Haskell generics and reflection-persist :: (Entity a) => a -> GP ()-persist entity = do-  conn <- askConnection-  resultRows <- liftIO $ quickQuery conn preparedSelectStmt [eid]+persist :: forall a. (Entity a) => Conn -> a -> IO ()+persist conn entity = do+  eid <- idValue conn entity+  resultRows <- quickQuery conn preparedSelectStmt [eid]   case resultRows of-    []           -> insert entity-    [_singleRow] -> update entity+    []           -> insert conn entity+    [_singleRow] -> update conn entity     _            -> error $ "More than one entity found for id " ++ show eid   where-    ti = typeInfo entity-    eid = idValue entity-    preparedSelectStmt = selectStmtFor ti+    preparedSelectStmt = selectStmtFor @a  -- | A function that explicitely inserts an entity into a database.-insert :: (Entity a) => a -> GP ()-insert entity = do-  conn <- askConnection-  row <- toRow entity-  _rowcount <- liftIO $ run conn (insertStmtFor entity) row-  liftIO $ commit conn---- | A function that explicitely updates an entity in a database.-update :: (Entity a) => a -> GP ()-update entity = do-  conn <- askConnection-  row <- toRow entity-  _rowcount <- liftIO $ run conn (updateStmtFor entity) (row ++ [idValue entity])-  liftIO $ commit conn--delete :: (Entity a) => a -> GP ()-delete entity = do-  conn <- askConnection-  _rowCount <- liftIO $ run conn (deleteStmtFor entity) [idValue entity]-  liftIO $ commit conn---- | set up a table for a given entity type. The table is dropped and recreated.-setupTableFor :: forall a. (Entity a) => GP a-setupTableFor = do-  conn <- askConnection-  _ <- liftIO $ runRaw conn (dropTableStmtFor ti)-  _ <- liftIO $ runRaw conn (createTableStmtFor ti)-  liftIO $ commit conn-  return x-  where-    ti = typeInfoFromContext :: TypeInfo a-    x = evidenceFrom ti :: a+insert :: forall a. (Entity a) => Conn -> a -> IO ()+insert conn entity = do+  row <- toRow conn entity+  _rowcount <- run conn (insertStmtFor @a) row+  when (implicitCommit conn) $ commit conn +-- | A function that inserts a list of entities into a database.+--   The function takes an HDBC connection and a list of entities as parameters.+--   The insert-statement is compiled only once and then executed for each entity.+insertMany :: forall a. (Entity a) => Conn -> [a] -> IO ()+insertMany conn entities = do+  rows <- mapM (toRow conn) entities+  stmt <- prepare conn (insertStmtFor @a)+  executeMany stmt rows+  when (implicitCommit conn) $ commit conn+   --- | Lookup an entity in the cache, or retrieve it from the database.---   The Entity is identified by its EntityId, which is a (typeRep, idValue) tuple.-getElseRetrieve :: forall a . (Entity a) => EntityId -> GP (Maybe a)-getElseRetrieve eid@(_tr,pk) = do-  rc <- askCache-  case lookup eid rc of-    Just dyn -> case fromDynamic dyn :: Maybe a of-      Just e -> pure (Just e)-      Nothing -> error "should not be possible" -    Nothing -> retrieveById pk :: GP (Maybe a)+-- | A function that explicitely updates an entity in a database.+update :: forall a. (Entity a) => Conn -> a -> IO ()+update conn entity = do+  eid <- idValue conn entity+  row <- toRow conn entity+  _rowcount <- run conn (updateStmtFor @a) (row ++ [eid])+  when (implicitCommit conn) $ commit conn +-- | A function that updates a list of entities in a database.+--   The function takes an HDBC connection and a list of entities as parameters.+--   The update-statement is compiled only once and then executed for each entity.+updateMany :: forall a. (Entity a) => Conn -> [a] -> IO ()+updateMany conn entities = do+  eids <- mapM (idValue conn) entities+  rows <- mapM (toRow conn) entities+  stmt <- prepare conn (updateStmtFor @a)+  -- the update statement has one more parameter than the row: the id value for the where clause+  executeMany stmt (zipWith (\l x -> l ++ [x]) rows eids)+  when (implicitCommit conn) $ commit conn -extendCtxCache :: Entity a => a -> Ctx -> Ctx-extendCtxCache x (Ctx conn rc) = Ctx conn (cacheEntry : rc)-  where-    cacheEntry = (entityId x, toDyn x)+delete :: forall a. (Entity a) => Conn -> a -> IO ()+delete conn entity = do+  eid <- idValue conn entity+  _rowCount <- run conn (deleteStmtFor @a) [eid]+  when (implicitCommit conn) $ commit conn +-- | set up a table for a given entity type. The table is dropped and recreated.+setupTableFor :: forall a. (Entity a) => Conn -> IO ()+setupTableFor conn = do+  runRaw conn $ dropTableStmtFor @a+  runRaw conn $ createTableStmtFor @a (db conn)+  when (implicitCommit conn) $ commit conn  -- | Computes the EntityId of an entity. --   The EntityId of an entity is a (typeRep, idValue) tuple.-entityId :: (Entity a) => a -> EntityId-entityId x = (typeOf x, idValue x)+entityId :: forall a. (Entity a) => Conn -> a -> IO EntityId+entityId conn x = do+  eid <- idValue conn x+  return (tyName, eid)+  where+    tyName = constructorName (typeInfo @a)  -- | A function that returns the primary key value of an entity as a SqlValue.-idValue :: forall a. (Entity a) => a -> SqlValue-idValue x = fieldValue x (idField x)--askConnection :: GP ConnWrapper-askConnection = connection <$> ask+idValue :: forall a. (Entity a) => Conn -> a -> IO SqlValue+idValue conn x = do+  sqlValues <- toRow conn x+  return (sqlValues !! idFieldIndex)+  where+    idFieldIndex = fieldIndex @a (idField @a) -askCache :: GP ResolutionCache-askCache = cache <$> ask+-- | returns the index of a field of an entity.+--   The index is the position of the field in the list of fields of the entity.+--   If no such field exists, an error is thrown.+fieldIndex :: forall a. (Entity a) => String -> Int+fieldIndex fieldName =+  expectJust+    ("Field " ++ fieldName ++ " is not present in type " ++ constructorName ti)+    (elemIndex fieldName fieldList)+  where+    ti = typeInfo @a+    fieldList = fieldNames ti -runGP :: (MonadIO m, IConnection conn) => conn -> RIO Ctx a -> m a-runGP conn = runRIO (Ctx (ConnWrapper conn) mempty)+expectJust :: String -> Maybe a -> a+expectJust _ (Just x)  = x+expectJust err Nothing = error ("expectJust " ++ err)  -- These instances are needed to make the Convertible type class work with Enum types out of the box.-instance {-# OVERLAPS #-} forall a . (Enum a) => Convertible SqlValue a where+instance {-# OVERLAPS #-} forall a. (Enum a) => Convertible SqlValue a where   safeConvert :: SqlValue -> ConvertResult a   safeConvert = Right . toEnum . fromSql -instance {-# OVERLAPS #-} forall a . (Enum a) => Convertible a SqlValue where+instance {-# OVERLAPS #-} forall a. (Enum a) => Convertible a SqlValue where   safeConvert :: a -> ConvertResult SqlValue-  safeConvert = Right . toSql . fromEnum  +  safeConvert = Right . toSql . fromEnum

@@ -1,146 +0,0 @@-{-# LANGUAGE GADTs     #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE AllowAmbiguousTypes #-}---module Database.GP.RecordtypeReflection-  ( -    fieldValue,-    gFromRow,-    gToRow,-  )-where--import           Control.Monad                  (zipWithM)-import           Control.Monad.Trans.Class      (lift)-import           Control.Monad.Trans.State.Lazy (StateT (..))-import qualified Data.ByteString                as B-import           Data.Data                      hiding (typeRep)-import           Data.Dynamic                   (Dynamic, fromDynamic, toDyn)-import           Data.Int                       (Int32, Int64)-import           Data.List                      (elemIndex, uncons)-import           Data.Ratio                     (Ratio)-import qualified Data.Text                      as TS-import qualified Data.Text.Lazy                 as TL-import           Data.Time                      (Day, LocalTime,-                                                 NominalDiffTime, TimeOfDay,-                                                 UTCTime, ZonedTime)-import           Data.Time.Clock.POSIX          (POSIXTime)-import           Data.Word                      (Word32, Word64)-import           Database.HDBC                  (SqlValue, fromSql, toSql)-import           GHC.Data.Maybe                 (expectJust)-import           Type.Reflection                (SomeTypeRep (..), eqTypeRep,-                                                 typeRep)-import           Database.GP.TypeInfo---- | A function that takes an entity and a field name as input parameters and returns the value of the field as a String.---  Example: fieldValue (Person "John" 42) "name" = SqlString "John"---  Example: fieldValue (Person "John" 42) "age" = SqlInt64 42---  if the field is not present in the entity, an error is thrown.-fieldValue :: Data a => a -> String -> SqlValue-fieldValue x field =-  convertToSqlValue fieldType (valueList !! index)-  where-    ti = typeInfo x-    fieldList = fieldNames ti-    valueList = fieldValues x-    index =-      expectJust-        ("Field " ++ field ++ " is not present in type " ++ typeName ti)-        (elemIndex field fieldList)-    fieldType = fieldTypes ti !! index--fieldValues :: (Data a) => a -> [Dynamic]-fieldValues = gmapQ toDyn--gFromRow :: forall a. (Data a) => [SqlValue] -> a-gFromRow row = expectJust errMsg (buildFromRecord ti row)-  where-    ti = typeInfoFromContext-    tName = typeName ti-    errMsg = "can't construct an " ++ tName ++ " instance from " ++ show row--gToRow :: (Data a) => a -> [SqlValue]-gToRow x = zipWith convertToSqlValue types values-  where-    ti = typeInfo x-    types = fieldTypes ti-    values = fieldValues x---- | This function takes a `TypeInfo a`and a List of HDBC `SqlValue`s and returns a `Maybe a`.---  If the conversion fails, Nothing is returned, otherwise Just a.-buildFromRecord :: (Data a) => TypeInfo a -> [SqlValue] -> Maybe a-buildFromRecord ti record = applyConstr ctor dynamicsArgs-  where-    ctor = typeConstructor ti-    types = fieldTypes ti-    dynamicsArgs =-      expectJust-        ("buildFromRecord: error in converting record " ++ show record)-        (zipWithM convertToDynamic types record)---- | This function takes a `Constr` and a list of `Dynamic` values and returns a `Maybe a`.---   If an `a`entity could be constructed, Just a is returned, otherwise Nothing.---   See also https://stackoverflow.com/questions/47606189/fromconstrb-or-something-other-useful---   for Info on how to use fromConstrM-applyConstr :: Data a => Constr -> [Dynamic] -> Maybe a-applyConstr ctor args =-  let nextField :: forall d. Data d => StateT [Dynamic] Maybe d-      nextField = StateT uncons >>= lift . fromDynamic-   in case runStateT (fromConstrM nextField ctor) args of-        Just (x, []) -> Just x-        _            -> Nothing -- runtime type error or too few / too many arguments---- | convert a SqlValue into a Dynamic value that is backed by a value of the type represented by the SomeTypeRep parameter.---  If conversion fails, return Nothing.---  conversion to Dynamic is required to allow the use of fromDynamic in applyConstr---  see also https://stackoverflow.com/questions/46992740/how-to-specify-type-of-value-via-typerep-convertToDynamic :: SomeTypeRep -> SqlValue -> Maybe Dynamic-convertToDynamic (SomeTypeRep rep) val-  | Just HRefl <- eqTypeRep rep (typeRep @Int) = Just $ toDyn (fromSql val :: Int)-  | Just HRefl <- eqTypeRep rep (typeRep @Double) = Just $ toDyn (fromSql val :: Double)-  | Just HRefl <- eqTypeRep rep (typeRep @String) = Just $ toDyn (fromSql val :: String)-  | Just HRefl <- eqTypeRep rep (typeRep @Char) = Just $ toDyn (fromSql val :: Char)-  | Just HRefl <- eqTypeRep rep (typeRep @B.ByteString) = Just $ toDyn (fromSql val :: B.ByteString)-  | Just HRefl <- eqTypeRep rep (typeRep @Word32) = Just $ toDyn (fromSql val :: Word32)-  | Just HRefl <- eqTypeRep rep (typeRep @Word64) = Just $ toDyn (fromSql val :: Word64)-  | Just HRefl <- eqTypeRep rep (typeRep @Int32) = Just $ toDyn (fromSql val :: Int32)-  | Just HRefl <- eqTypeRep rep (typeRep @Int64) = Just $ toDyn (fromSql val :: Int64)-  | Just HRefl <- eqTypeRep rep (typeRep @Integer) = Just $ toDyn (fromSql val :: Integer)-  | Just HRefl <- eqTypeRep rep (typeRep @Bool) = Just $ toDyn (fromSql val :: Bool)-  | Just HRefl <- eqTypeRep rep (typeRep @UTCTime) = Just $ toDyn (fromSql val :: UTCTime)-  | Just HRefl <- eqTypeRep rep (typeRep @POSIXTime) = Just $ toDyn (fromSql val :: POSIXTime)-  | Just HRefl <- eqTypeRep rep (typeRep @LocalTime) = Just $ toDyn (fromSql val :: LocalTime)-  | Just HRefl <- eqTypeRep rep (typeRep @ZonedTime) = Just $ toDyn (fromSql val :: ZonedTime)-  | Just HRefl <- eqTypeRep rep (typeRep @TimeOfDay) = Just $ toDyn (fromSql val :: TimeOfDay)-  | Just HRefl <- eqTypeRep rep (typeRep @Day) = Just $ toDyn (fromSql val :: Day)-  | Just HRefl <- eqTypeRep rep (typeRep @NominalDiffTime) = Just $ toDyn (fromSql val :: NominalDiffTime)-  | Just HRefl <- eqTypeRep rep (typeRep @Ratio) = Just $ toDyn (fromSql val :: Ratio Integer)-  | Just HRefl <- eqTypeRep rep (typeRep @TL.Text) = Just $ toDyn (fromSql val :: TL.Text)-  | Just HRefl <- eqTypeRep rep (typeRep @TS.Text) = Just $ toDyn (fromSql val :: TS.Text)-  | otherwise = Nothing--convertToSqlValue :: SomeTypeRep -> Dynamic -> SqlValue-convertToSqlValue (SomeTypeRep rep) dyn-  | Just HRefl <- eqTypeRep rep (typeRep @Int) = toSql (expectJust ("Not an Int: " ++ show dyn) (fromDynamic dyn) :: Int)-  | Just HRefl <- eqTypeRep rep (typeRep @Double) = toSql (expectJust ("Not a Double: " ++ show dyn) (fromDynamic dyn) :: Double)-  | Just HRefl <- eqTypeRep rep (typeRep @String) = toSql (expectJust ("Not a String: " ++ show dyn) (fromDynamic dyn) :: String)-  | Just HRefl <- eqTypeRep rep (typeRep @Char) = toSql (expectJust ("Not a Char: " ++ show dyn) (fromDynamic dyn) :: Char)-  | Just HRefl <- eqTypeRep rep (typeRep @B.ByteString) = toSql (expectJust ("Not a ByteString: " ++ show dyn) (fromDynamic dyn) :: B.ByteString)-  | Just HRefl <- eqTypeRep rep (typeRep @Word32) = toSql (expectJust ("Not a Word32: " ++ show dyn) (fromDynamic dyn) :: Word32)-  | Just HRefl <- eqTypeRep rep (typeRep @Word64) = toSql (expectJust ("Not a Word64: " ++ show dyn) (fromDynamic dyn) :: Word64)-  | Just HRefl <- eqTypeRep rep (typeRep @Int32) = toSql (expectJust ("Not an Int32: " ++ show dyn) (fromDynamic dyn) :: Int32)-  | Just HRefl <- eqTypeRep rep (typeRep @Int64) = toSql (expectJust ("Not an Int64: " ++ show dyn) (fromDynamic dyn) :: Int64)-  | Just HRefl <- eqTypeRep rep (typeRep @Integer) = toSql (expectJust ("Not an Integer: " ++ show dyn) (fromDynamic dyn) :: Integer)-  | Just HRefl <- eqTypeRep rep (typeRep @Bool) = toSql (expectJust ("Not a Bool: " ++ show dyn) (fromDynamic dyn) :: Bool)-  | Just HRefl <- eqTypeRep rep (typeRep @UTCTime) = toSql (expectJust ("Not a UTCTime: " ++ show dyn) (fromDynamic dyn) :: UTCTime)-  | Just HRefl <- eqTypeRep rep (typeRep @POSIXTime) = toSql (expectJust ("Not a PosixTime: " ++ show dyn) (fromDynamic dyn) :: POSIXTime)-  | Just HRefl <- eqTypeRep rep (typeRep @LocalTime) = toSql (expectJust ("Not a LocalTime: " ++ show dyn) (fromDynamic dyn) :: LocalTime)-  | Just HRefl <- eqTypeRep rep (typeRep @ZonedTime) = toSql (expectJust ("Not a ZonedTime: " ++ show dyn) (fromDynamic dyn) :: ZonedTime)-  | Just HRefl <- eqTypeRep rep (typeRep @TimeOfDay) = toSql (expectJust ("Not a TimeOfDay: " ++ show dyn) (fromDynamic dyn) :: TimeOfDay)-  | Just HRefl <- eqTypeRep rep (typeRep @Day) = toSql (expectJust ("Not a Day: " ++ show dyn) (fromDynamic dyn) :: Day)-  | Just HRefl <- eqTypeRep rep (typeRep @NominalDiffTime) = toSql (expectJust ("Not a NominalTimeDiff: " ++ show dyn) (fromDynamic dyn) :: NominalDiffTime)-  | Just HRefl <- eqTypeRep rep (typeRep @Ratio) = toSql (expectJust ("Not a Ratio: " ++ show dyn) (fromDynamic dyn) :: Ratio Integer)-  | Just HRefl <- eqTypeRep rep (typeRep @TL.Text) = toSql (expectJust ("Not a TL.Text: " ++ show dyn) (fromDynamic dyn) :: TL.Text)-  | Just HRefl <- eqTypeRep rep (typeRep @TS.Text) = toSql (expectJust ("Not a TS.Text: " ++ show dyn) (fromDynamic dyn) :: TS.Text)-  | otherwise = error $ "convertToSqlValue: " ++ show rep ++ " not supported"

@@ -1,3 +1,5 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+ module Database.GP.SqlGenerator   ( insertStmtFor,     updateStmtFor,@@ -10,128 +12,118 @@   ) where -import           Data.List (intercalate)+import           Data.List          (intercalate) import           Database.GP.Entity-import           Database.GP.TypeInfo  -- | A function that returns an SQL insert statement for an entity. Type 'a' must be an instance of Data. -- The function will use the field names of the data type to generate the column names in the insert statement. -- The values of the fields will be used as the values in the insert statement. -- Output example: INSERT INTO Person (id, name, age, address) VALUES (123456, "Alice", 25, "123 Main St");-insertStmtFor :: Entity a => a -> String-insertStmtFor x =+insertStmtFor :: forall a. Entity a => String+insertStmtFor =   "INSERT INTO "-    ++ tableName x+    ++ tableName @a     ++ " ("     ++ intercalate ", " columns     ++ ") VALUES ("     ++ intercalate ", " (params (length columns))     ++ ");"   where-    columns = columnNamesFor x-+    columns = columnNamesFor @a -columnNamesFor :: Entity a => a -> [String]-columnNamesFor x =  map snd fieldColumnPairs+columnNamesFor :: forall a. Entity a => [String]+columnNamesFor = map snd fieldColumnPairs   where-    fieldColumnPairs = fieldsToColumns x -+    fieldColumnPairs = fieldsToColumns @a  params :: Int -> [String] params n = replicate n "?"  -- | A function that returns an SQL update statement for an entity. Type 'a' must be an instance of Entity.-updateStmtFor :: Entity a => a -> String-updateStmtFor x =+updateStmtFor :: forall a. (Entity a) => String+updateStmtFor =   "UPDATE "-    ++ tableName x+    ++ tableName @a     ++ " SET "     ++ intercalate ", " updatePairs     ++ " WHERE "-    ++ idColumn x+    ++ idColumn @a     ++ " = ?"     ++ ";"   where-    updatePairs = map (++ " = ?") (columnNamesFor x)+    updatePairs = map (++ " = ?") (columnNamesFor @a) -idColumn :: Entity a => a -> String-idColumn x = columnNameFor x (idField x)+idColumn :: forall a. (Entity a) => String+idColumn = columnNameFor @a (idField @a)  -- | A function that returns an SQL select statement for entity type `a` with primary key `id`.-selectStmtFor :: forall a. (Entity a) => TypeInfo a -> String-selectStmtFor ti =+selectStmtFor :: forall a. (Entity a) => String+selectStmtFor =   "SELECT "-    ++ intercalate ", " (columnNamesFor x)+    ++ intercalate ", " (columnNamesFor @a)     ++ " FROM "-    ++ tableName x+    ++ tableName @a     ++ " WHERE "-    ++ idColumn x+    ++ idColumn @a     ++ " = ?;"-  where-    x = evidenceFrom ti :: a -selectAllStmtFor :: forall a. (Entity a) => TypeInfo a -> String-selectAllStmtFor ti =+selectAllStmtFor :: forall a. (Entity a) => String+selectAllStmtFor =   "SELECT "-    ++ intercalate ", " (columnNamesFor x)+    ++ intercalate ", " (columnNamesFor @a)     ++ " FROM "-    ++ tableName x+    ++ tableName @a     ++ ";"-  where-    x = evidenceFrom ti :: a -selectAllWhereStmtFor :: forall a. (Entity a) => TypeInfo a -> String -> String-selectAllWhereStmtFor ti field =+selectAllWhereStmtFor :: forall a. (Entity a) => String -> String+selectAllWhereStmtFor field =   "SELECT "-    ++ intercalate ", " (columnNamesFor x)+    ++ intercalate ", " (columnNamesFor @a)     ++ " FROM "-    ++ tableName x+    ++ tableName @a     ++ " WHERE "     ++ column     ++ " = ?;"   where-    x = evidenceFrom ti :: a-    column = columnNameFor x field+    column = columnNameFor @a field -deleteStmtFor :: Entity a => a -> String-deleteStmtFor x =+deleteStmtFor :: forall a. (Entity a) => String+deleteStmtFor =   "DELETE FROM "-    ++ tableName x+    ++ tableName @a     ++ " WHERE "-    ++ idColumn x+    ++ idColumn @a     ++ " = ?;" -createTableStmtFor :: forall a. (Entity a) => TypeInfo a -> String-createTableStmtFor ti =+createTableStmtFor :: forall a. (Entity a) => Database -> String+createTableStmtFor dbServer =   "CREATE TABLE "-    ++ tableName x+    ++ tableName @a     ++ " ("-    ++ intercalate ", " (map (\(f,c) -> c ++ " " ++ columnTypeFor x f ++ optionalPK f) (fieldsToColumns x))+    ++ intercalate ", " (map (\(f, c) -> c ++ " " ++ columnTypeFor @a dbServer f ++ optionalPK f) (fieldsToColumns @a))     ++ ");"   where-    x = evidenceFrom ti :: a-    isIdField f = f == idField x+    isIdField f = f == idField @a     optionalPK f = if isIdField f then " PRIMARY KEY" else ""-    -    -columnTypeFor :: forall a. (Entity a) => a -> String -> String-columnTypeFor x field = ++-- | A function that returns the column type for a field of an entity.+-- TODO: Support other databases than just SQLite.+columnTypeFor :: forall a. (Entity a) => Database -> String -> String+columnTypeFor SQLite field =   case fType of-    "Int" -> "INTEGER"+    "Int"    -> "INTEGER"     "String" -> "TEXT"     "Double" -> "REAL"-    "Float" -> "REAL"-    "Bool" -> "INT"-    _ -> "TEXT"-    where-      maybeFType = maybeFieldTypeFor x field-      fType = maybe "OTHER" show maybeFType-+    "Float"  -> "REAL"+    "Bool"   -> "INT"+    _        -> "TEXT"+  where+    maybeFType = maybeFieldTypeFor @a field+    fType = maybe "OTHER" show maybeFType+columnTypeFor other _ = error $ "Schema creation for " ++ show other ++ " not implemented yet" -dropTableStmtFor :: forall a. (Entity a) => TypeInfo a -> String-dropTableStmtFor ti =+dropTableStmtFor :: forall a. (Entity a) => String+dropTableStmtFor =   "DROP TABLE IF EXISTS "-    ++ tableName x+    ++ tableName @a     ++ ";"-  where-    x = evidenceFrom ti :: a

@@ -1,25 +1,27 @@---{-# LANGUAGE RankNTypes           #-}---{-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+ module Database.GP.TypeInfo   ( TypeInfo,-    typeConstructor,     fieldNames,     fieldTypes,-    typeName,+    constructorName,     typeInfo,-    typeInfoFromContext,+    HasConstructor (..),+    HasSelectors (..),   ) where -import Data.Data+import           Data.Kind       (Type)+import           GHC.Generics+import           Type.Reflection (SomeTypeRep (..), Typeable, typeRep) --- | A data type holding meta-data about a type. +-- | A data type holding meta-data about a type. --   The Phantom type parameter `a` ensures type safety for reflective functions --   that use this type to create type instances (See module RecordtypeReflection). data TypeInfo a = TypeInfo-  { typeConstructor :: Constr,+  { constructorName :: String,     fieldNames      :: [String],-    fieldTypes      :: [TypeRep]+    fieldTypes      :: [SomeTypeRep]   }   deriving (Show) @@ -27,45 +29,54 @@ --   It takes a value of type `a` and returns a `TypeInfo a` object. --   If the type has no named fields, an error is thrown. --   If the type has more than one constructor, an error is thrown.-typeInfo :: Data a => a -> TypeInfo a-typeInfo x =+typeInfo :: forall a. (HasConstructor (Rep a), HasSelectors (Rep a), Generic a) => TypeInfo a+typeInfo =   TypeInfo-    { typeConstructor = ensureSingleConstructor (dataTypeOf x),-      fieldNames = fieldNamesOf x,-      fieldTypes = gmapQ typeOf x+    { constructorName = gConstrName x,+      fieldNames = map fst (gSelectors x),+      fieldTypes = map snd (gSelectors x)     }+  where+    x = undefined :: a --- | This function ensures that the type of `a` has exactly one constructor.---   If the type has exactly one constructor, the constructor is returned.---   otherwise, an error is thrown.-ensureSingleConstructor :: DataType -> Constr-ensureSingleConstructor dt =-  case dataTypeConstrs dt of-    [cnstr] -> cnstr-    _ -> error $ "ensureSingleConstructor: Only types with one constructor are supported (" ++ show dt ++ ")"+-- Generic implementations --- | This function creates a TypeInfo object from the context of a function call.---   The Phantom Type parameter `a` is used to convince the compiler that the `TypeInfo a` object really describes type `a`.---   See also https://stackoverflow.com/questions/75171829/how-to-obtain-a-data-data-constr-etc-from-a-type-representation-typeInfoFromContext :: forall a. Data a => TypeInfo a-typeInfoFromContext =-  let dt = dataTypeOf (undefined :: a)    -- This is the trick to get the type a from the context.-      constr = ensureSingleConstructor dt-      evidence = fromConstr constr :: a   -- this is evidence for the compiler that we have a value of type a-   in typeInfo evidence+gConstrName :: (HasConstructor (Rep a), Generic a) => a -> String+gConstrName = genericConstrName . from --- | This function returns the (unqualified) type name of `a` from a `TypeInfo a` object.-typeName :: TypeInfo a -> String-typeName = dataTypeName . constrType . typeConstructor+class HasConstructor (f :: Type -> Type) where+  genericConstrName :: f x -> String --- | This function returns the list of field names of an entity of type `a`.-fieldNamesOf :: (Data a) => a -> [String]-fieldNamesOf x = names-  where-    constructor = toConstr x-    candidates = constrFields constructor-    constrs = gmapQ toConstr x-    names =-      if length candidates == length constrs-        then candidates-        else error $ "fieldNamesOf: Type " ++ show (typeOf x) ++ " does not have named fields"+instance HasConstructor f => HasConstructor (D1 c f) where+  genericConstrName (M1 x) = genericConstrName x++instance (HasConstructor x, HasConstructor y) => HasConstructor (x :+: y) where+  genericConstrName (L1 l) = genericConstrName l+  genericConstrName (R1 r) = genericConstrName r++instance Constructor c => HasConstructor (C1 c f) where+  genericConstrName = conName++-- field names & types++gSelectors :: forall a. (HasSelectors (Rep a)) => a -> [(String, SomeTypeRep)]+gSelectors _x = selectors @(Rep a)++class HasSelectors rep where+  selectors :: [(String, SomeTypeRep)]++instance HasSelectors f => HasSelectors (M1 D x f) where+  selectors = selectors @f++instance HasSelectors f => HasSelectors (M1 C x f) where+  selectors = selectors @f++instance (Selector s, Typeable t) => HasSelectors (M1 S s (K1 R t)) where+  selectors =+    [(selName (undefined :: M1 S s (K1 R t) ()), SomeTypeRep (typeRep @t))]++instance (HasSelectors a, HasSelectors b) => HasSelectors (a :*: b) where+  selectors = selectors @a ++ selectors @b++instance HasSelectors U1 where+  selectors = []

@@ -1,26 +1,27 @@+{-# LANGUAGE DeriveAnyClass #-}+ module EmbeddedSpec-  ( test-  , spec-  ) where+  ( test,+    spec,+  )+where -import          Test.Hspec-import          Data.Data-import          Database.HDBC-import          Database.HDBC.Sqlite3-import          Database.GP.GenericPersistence-import          RIO    +import           Database.GP.GenericPersistence+import           Database.HDBC+import           Database.HDBC.Sqlite3+import           GHC.Generics+import           Test.Hspec  -- `test` is here so that this module can be run from GHCi on its own.  It is -- not needed for automatic spec discovery. (start up stack repl --test to bring up ghci and have access to all the test functions) test :: IO () test = hspec spec -withDatabase :: RIO Ctx a -> IO a-withDatabase action = do-  conn <- connectSqlite3 ":memory:"-  runGP conn $ do-    _ <- setupTableFor :: GP Article-    action+prepareDB :: IO Conn+prepareDB = do+  conn <- connect SQLite <$> connectSqlite3 ":memory:"+  setupTableFor @Article conn+  return conn  data Article = Article   { articleID :: Int,@@ -28,56 +29,61 @@     author    :: Author,     year      :: Int   }-  deriving (Data, Show, Eq)+  deriving (Generic, Show, Eq)  data Author = Author   { authorID :: Int,     name     :: String,     address  :: String   }-  deriving (Data, Show, Eq)  +  deriving (Generic, Show, Eq)  instance Entity Article where--  fieldsToColumns :: Article -> [(String, String)]-  fieldsToColumns _ = [("articleID", "articleID"),-                       ("title", "title"), -                       ("authorID", "authorID"), -                       ("authorName", "authorName"), -                       ("authorAddress", "authorAddress"),-                       ("year", "year")-                      ]+  fieldsToColumns =+    [ ("articleID", "articleID"),+      ("title", "title"),+      ("authorID", "authorID"),+      ("authorName", "authorName"),+      ("authorAddress", "authorAddress"),+      ("year", "year")+    ] -  fromRow row = return $ Article (col 0) (col 1) author (col 5)+  fromRow :: Conn -> [SqlValue] -> IO Article+  fromRow _ r = return $ fromRowWoCtx r     where-      col i = fromSql (row !! i)-      author = Author (col 2) (col 3) (col 4)+      fromRowWoCtx row = Article (col 0) (col 1) author (col 5)+        where+          col i = fromSql (row !! i)+          author = Author (col 2) (col 3) (col 4) -  toRow  a = return [toSql (articleID a), toSql (title a), toSql authID, toSql authorName, toSql authorAddress, toSql (year a)]-    where -      authID = authorID (author a)-      authorName = name (author a)-      authorAddress = address (author a)+  toRow _ art = return $ toRowWoCtx art+    where+      toRowWoCtx a = [toSql (articleID a), toSql (title a), toSql authID, toSql authorName, toSql authorAddress, toSql (year a)]+      authID = authorID (author art)+      authorName = name (author art)+      authorAddress = address (author art)  article :: Article-article = Article -  { articleID = 1, -    title = "Persistence without Boilerplate", -    author = Author -      {authorID = 1, -      name = "Arthur Dent", -      address = "Boston"}, -    year = 2018}+article =+  Article+    { articleID = 1,+      title = "Persistence without Boilerplate",+      author =+        Author+          { authorID = 1,+            name = "Arthur Dent",+            address = "Boston"+          },+      year = 2018+    }  spec :: Spec spec = do   describe "Handling of Embedded Objects" $ do-    it "works like a charm" $ -      withDatabase $ do-        insert article-        article' <- retrieveById "1" :: GP (Maybe Article)-        liftIO $ article' `shouldBe` Just article-        allArticles <- retrieveAll :: GP [Article]-        liftIO $ allArticles `shouldBe` [article]--+    it "works like a charm" $ do+      conn <- prepareDB+      insert conn article+      article' <- retrieveById conn "1" :: IO (Maybe Article)+      article' `shouldBe` Just article+      allArticles <- retrieveAll conn :: IO [Article]+      allArticles `shouldBe` [article]

@@ -1,60 +1,53 @@+{-# LANGUAGE DeriveAnyClass #-}+ module EnumSpec-  ( test-  , spec-  ) where+  ( test,+    spec,+  )+where -import          Test.Hspec-import          Data.Data-import          Database.HDBC-import          Database.HDBC.Sqlite3-import          Database.GP.GenericPersistence-import          RIO    +import           Data.Convertible+import           Database.GP.GenericPersistence+import           Database.HDBC+import           Database.HDBC.Sqlite3+import           GHC.Generics+import           Test.Hspec  -- `test` is here so that this module can be run from GHCi on its own.  It is -- not needed for automatic spec discovery. (start up stack repl --test to bring up ghci and have access to all the test functions) test :: IO () test = hspec spec -withDatabase :: RIO Ctx a -> IO a-withDatabase action = do-  conn <- connectSqlite3 ":memory:"-  runGP conn $ do-    _ <- setupTableFor :: GP Book-    action+prepareDB :: IO Conn+prepareDB = do+  conn <- connect SQLite <$> connectSqlite3 ":memory:"+  setupTableFor @Book conn+  return conn  data Book = Book-  { bookID :: Int,-    title   :: String,-    author  :: String,-    year    :: Int,+  { bookID   :: Int,+    title    :: String,+    author   :: String,+    year     :: Int,     category :: BookCategory   }-  deriving (Data, Show, Eq)+  deriving (Generic, Show, Eq, Entity)  data BookCategory = Fiction | Travel | Arts | Science | History | Biography | Other-  deriving (Data, Show, Read, Eq, Enum)-  -instance Entity Book where-  fromRow row = return $ Book (col 0) (col 1) (col 2) (col 3) (col 4)-    where-      col i = fromSql (row !! i)+  deriving (Generic, Show, Read, Eq) -  toRow b = return [toSql (bookID b), toSql (title b), toSql (author b), toSql (year b), toSql (category b)]+instance Convertible BookCategory SqlValue where+  safeConvert = Right . toSql . show --- instance Convertible BookCategory SqlValue where---   safeConvert = Right . toSql . show-  --- instance Convertible SqlValue BookCategory where---   safeConvert = Right . read . fromSql+instance Convertible SqlValue BookCategory where+  safeConvert = Right . read . fromSql  spec :: Spec spec = do   describe "Handling of Enum Fields" $ do-    it "works like a charm" $ -      withDatabase $ do-        let book = Book 1 "The Hobbit" "J.R.R. Tolkien" 1937 Fiction-        insert book-        allBooks <- retrieveAll :: GP [Book]-        liftIO $ allBooks `shouldBe` [book]--+    it "works like a charm" $ do+      conn <- prepareDB+      let book = Book 1 "The Hobbit" "J.R.R. Tolkien" 1937 Fiction+      insert conn book+      allBooks <- retrieveAll conn :: IO [Book]+      allBooks `shouldBe` [book]

@@ -1,33 +1,29 @@-{-# LANGUAGE DeriveAnyClass     #-}  -- allows automatic derivation from Entity type class-module GenericPersistenceSpec-  ( test-  , spec-  , withDatabase-  ) where+-- allows automatic derivation from Entity type class+{-# LANGUAGE DeriveAnyClass #-} +module GenericPersistenceSpec+  ( test,+    spec,+  )+where -import           Test.Hspec-import           Data.Data             -import           Database.HDBC         -import           Database.HDBC.Sqlite3 import           Database.GP.GenericPersistence-import           RIO--+import           Database.HDBC+import           Database.HDBC.Sqlite3+import           GHC.Generics+import           Test.Hspec  -- `test` is here so that this module can be run from GHCi on its own.  It is -- not needed for automatic spec discovery. (start up stack repl --test to bring up ghci and have access to all the test functions) test :: IO () test = hspec spec -withDatabase :: RIO Ctx a -> IO a-withDatabase action = do-  conn <- connectSqlite3 ":memory:"-  let ctx = Ctx (ConnWrapper conn) mempty-  runRIO ctx $ do-    _ <- setupTableFor :: GP Person-    _ <- setupTableFor :: GP Book-    action+prepareDB :: IO Conn+prepareDB = do+  conn <- connect SQLite <$> connectSqlite3 ":memory:"+  setupTableFor @Person conn+  setupTableFor @Book conn+  return conn  -- | A data type with several fields, using record syntax. data Person = Person@@ -36,149 +32,171 @@     age      :: Int,     address  :: String   }-  deriving (Data, Entity, Show, Eq)+  deriving (Generic, Entity, Show, Eq)  data Book = Book-  { book_id :: Int,-    title   :: String,-    author  :: String,-    year    :: Int,+  { book_id  :: Int,+    title    :: String,+    author   :: String,+    year     :: Int,     category :: BookCategory   }-  deriving (Data, Show, Eq)+  deriving (Generic, Show, Eq)  data BookCategory = Fiction | Travel | Arts | Science | History | Biography | Other-  deriving (Data, Read, Show, Eq, Enum)+  deriving (Generic, Read, Show, Eq, Enum) -   instance Entity Book where-  idField _ = "book_id"-  fieldsToColumns _ = [("book_id", "bookId"), ("title", "bookTitle"), ("author", "bookAuthor"), ("year", "bookYear"), ("category", "bookCategory")]-  tableName _ = "BOOK_TBL"-  fromRow row = pure $ Book (col 0) (col 1) (col 2) (col 3) (col 4)+  idField = "book_id"+  fieldsToColumns = [("book_id", "bookId"), ("title", "bookTitle"), ("author", "bookAuthor"), ("year", "bookYear"), ("category", "bookCategory")]+  tableName = "BOOK_TBL"+  fromRow _c row = pure $ Book (col 0) (col 1) (col 2) (col 3) (col 4)     where       col i = fromSql (row !! i) -  toRow b = pure [toSql (book_id b), toSql (title b), toSql (author b), toSql (year b), toSql (category b)]-+  toRow _c b = pure [toSql (book_id b), toSql (title b), toSql (author b), toSql (year b), toSql (category b)]  person :: Person person = Person 123456 "Alice" 25 "123 Main St" +manyPersons :: [Person]+manyPersons =+  [ Person 1 "Alice" 25 "123 Main St",+    Person 2 "Bob" 30 "456 Elm St",+    Person 3 "Charlie" 35 "789 Pine St",+    Person 4 "Dave" 40 "1011 Oak St",+    Person 5 "Eve" 45 "1213 Maple St",+    Person 6 "Frank" 50 "1415 Walnut St"+  ]++ book :: Book book = Book 1 "The Hobbit" "J.R.R. Tolkien" 1937 Fiction - spec :: Spec spec = do   describe "GenericPersistence" $ do-    it "retrieves Entities using Generics" $ -      withDatabase $ do-        let bob = Person 1 "Bob" 36 "7 West Street"-        Ctx conn _ <- ask-        liftIO $ runRaw conn "INSERT INTO Person (personID, name, age, address) VALUES (1, \"Bob\", 36, \"7 West Street\");"-        liftIO $ runRaw conn "INSERT INTO Person (personID, name, age, address) VALUES (2, \"Alice\", 25, \"7 West Street\");"-        liftIO $ runRaw conn "INSERT INTO Person (personID, name, age, address) VALUES (3, \"Frank\", 56, \"7 West Street\");"-        allPersons <- retrieveAll :: GP [Person]-        liftIO $ length allPersons `shouldBe` 3-        liftIO $ head allPersons `shouldBe` bob-        person' <- retrieveById (1 :: Int) :: GP (Maybe Person)-        liftIO $ person' `shouldBe` Just bob-    it "retrieves Entities using user implementation" $-      withDatabase $ do+    it "retrieves Entities using Generics" $ do+      conn <- prepareDB+      let bob = Person 1 "Bob" 36 "7 West Street"+      runRaw conn "INSERT INTO Person (personID, name, age, address) VALUES (1, \"Bob\", 36, \"7 West Street\");"+      runRaw conn "INSERT INTO Person (personID, name, age, address) VALUES (2, \"Alice\", 25, \"7 West Street\");"+      runRaw conn "INSERT INTO Person (personID, name, age, address) VALUES (3, \"Frank\", 56, \"7 West Street\");"+      allPersons <- retrieveAll conn :: IO [Person]+      length allPersons `shouldBe` 3+      head allPersons `shouldBe` bob+      person' <- retrieveById conn (1 :: Int) :: IO (Maybe Person)+      person' `shouldBe` Just bob+    it "retrieves Entities using user implementation" $ do+      conn <- prepareDB       let hobbit = Book 1 "The Hobbit" "J.R.R. Tolkien" 1937 Fiction-      Ctx conn _ <- ask-      liftIO $ runRaw conn "INSERT INTO BOOK_TBL (bookId, bookTitle, bookAuthor, bookYear, bookCategory) VALUES (1, \"The Hobbit\", \"J.R.R. Tolkien\", 1937, 0);"-      liftIO $ runRaw conn "INSERT INTO BOOK_TBL (bookId, bookTitle, bookAuthor, bookYear, bookCategory) VALUES (2, \"The Lord of the Rings\", \"J.R.R. Tolkien\", 1955, 0);"-      liftIO $ runRaw conn "INSERT INTO BOOK_TBL (bookId, bookTitle, bookAuthor, bookYear, bookCategory) VALUES (3, \"Smith of Wootton Major\", \"J.R.R. Tolkien\", 1967, 0);"-      allBooks <- retrieveAll :: GP [Book]-      liftIO $ length allBooks `shouldBe` 3-      liftIO $ head allBooks `shouldBe` hobbit-      book' <- retrieveById(1 :: Int) :: GP (Maybe Book)-      liftIO $ book' `shouldBe` Just hobbit-    -    it "persists new Entities using Generics" $ -      withDatabase $ do-      allPersons <- retrieveAll :: GP [Person]-      liftIO $ length allPersons `shouldBe` 0-      persist person-      allPersons' <- retrieveAll :: GP [Person]-      liftIO $ length allPersons' `shouldBe` 1-      person' <- retrieveById (123456 :: Int) :: GP (Maybe Person)-      liftIO $ person' `shouldBe` Just person-    it "persists new Entities using user implementation" $ -      withDatabase $ do-      allbooks <- retrieveAll :: GP [Book]-      liftIO $ length allbooks `shouldBe` 0-      persist book-      allbooks' <- retrieveAll :: GP [Book]-      liftIO $ length allbooks' `shouldBe` 1-      book' <- retrieveById (1 :: Int) :: GP (Maybe Book) -      liftIO $ book' `shouldBe` Just book-    it "persists existing Entities using Generics" $-      withDatabase $ do-      allPersons <- retrieveAll :: GP [Person]-      liftIO $ length allPersons `shouldBe` 0-      persist person-      allPersons' <- retrieveAll :: GP [Person]-      liftIO $ length allPersons' `shouldBe` 1-      persist person {age = 26}-      person' <- retrieveById (123456 :: Int) :: GP (Maybe Person)-      liftIO $ person' `shouldBe` Just person {age = 26}-    it "persists existing Entities using user implementation" $-      withDatabase $ do-      allbooks <- retrieveAll :: GP [Book]-      liftIO $ length allbooks `shouldBe` 0-      persist book-      allbooks' <- retrieveAll :: GP [Book]-      liftIO $ length allbooks' `shouldBe` 1-      persist book {year = 1938}-      book' <- retrieveById (1 :: Int) :: GP (Maybe Book)-      liftIO $ book' `shouldBe` Just book {year = 1938}-    it "inserts Entities using Generics" $-      withDatabase $ do-      allPersons <- retrieveAll :: GP [Person]-      liftIO $ length allPersons `shouldBe` 0-      insert person-      allPersons' <- retrieveAll :: GP [Person]-      liftIO $ length allPersons' `shouldBe` 1-      person' <- retrieveById (123456 :: Int) :: GP (Maybe Person)-      liftIO $ person' `shouldBe` Just person-    it "inserts Entities using user implementation" $-      withDatabase $ do-      allbooks <- retrieveAll :: GP [Book]-      liftIO $ length allbooks `shouldBe` 0-      insert book-      allbooks' <- retrieveAll :: GP [Book]-      liftIO $ length allbooks' `shouldBe` 1-      book' <- retrieveById (1 :: Int) :: GP (Maybe Book)-      liftIO $ book' `shouldBe` Just book-    it "updates Entities using Generics" $-      withDatabase $ do-      insert person-      update person {name = "Bob"}-      person' <- retrieveById (123456 :: Int) :: GP (Maybe Person)-      liftIO $ person' `shouldBe` Just person {name = "Bob"}-    it "updates Entities using user implementation" $-      withDatabase $ do-      insert book-      update book {title = "The Lord of the Rings"}-      book' <- retrieveById (1 :: Int) :: GP (Maybe Book)-      liftIO $ book' `shouldBe` Just book {title = "The Lord of the Rings"}-    it "deletes Entities using Generics" $-      withDatabase $ do-      insert person-      allPersons <- retrieveAll :: GP [Person]-      liftIO $ length allPersons `shouldBe` 1-      delete person-      allPersons' <- retrieveAll :: GP [Person]-      liftIO $ length allPersons' `shouldBe` 0  -    it "deletes Entities using user implementation" $-      withDatabase $ do-      insert book-      allBooks <- retrieveAll :: GP [Book]-      liftIO $ length allBooks `shouldBe` 1-      delete book-      allBooks' <- retrieveAll :: GP [Book]-      liftIO $ length allBooks' `shouldBe` 0-      +      runRaw conn "INSERT INTO BOOK_TBL (bookId, bookTitle, bookAuthor, bookYear, bookCategory) VALUES (1, \"The Hobbit\", \"J.R.R. Tolkien\", 1937, 0);"+      runRaw conn "INSERT INTO BOOK_TBL (bookId, bookTitle, bookAuthor, bookYear, bookCategory) VALUES (2, \"The Lord of the Rings\", \"J.R.R. Tolkien\", 1955, 0);"+      runRaw conn "INSERT INTO BOOK_TBL (bookId, bookTitle, bookAuthor, bookYear, bookCategory) VALUES (3, \"Smith of Wootton Major\", \"J.R.R. Tolkien\", 1967, 0);"+      allBooks <- retrieveAll conn :: IO [Book]+      length allBooks `shouldBe` 3+      head allBooks `shouldBe` hobbit+      book' <- retrieveById conn (1 :: Int) :: IO (Maybe Book)+      book' `shouldBe` Just hobbit+    it "persists new Entities using Generics" $ do+      conn <- prepareDB+      allPersons <- retrieveAll conn :: IO [Person]+      length allPersons `shouldBe` 0+      persist conn person+      allPersons' <- retrieveAll conn :: IO [Person]+      length allPersons' `shouldBe` 1+      person' <- retrieveById conn (123456 :: Int) :: IO (Maybe Person)+      person' `shouldBe` Just person+    it "persists new Entities using user implementation" $ do+      conn <- prepareDB+      allbooks <- retrieveAll conn :: IO [Book]+      length allbooks `shouldBe` 0+      persist conn book+      allbooks' <- retrieveAll conn :: IO [Book]+      length allbooks' `shouldBe` 1+      book' <- retrieveById conn (1 :: Int) :: IO (Maybe Book)+      book' `shouldBe` Just book+    it "persists existing Entities using Generics" $ do+      conn <- prepareDB+      allPersons <- retrieveAll conn :: IO [Person]+      length allPersons `shouldBe` 0+      persist conn person+      allPersons' <- retrieveAll conn :: IO [Person]+      length allPersons' `shouldBe` 1+      persist conn person {age = 26}+      person' <- retrieveById conn (123456 :: Int) :: IO (Maybe Person)+      person' `shouldBe` Just person {age = 26}+    it "persists existing Entities using user implementation" $ do+      conn <- prepareDB+      allbooks <- retrieveAll conn :: IO [Book]+      length allbooks `shouldBe` 0+      persist conn book+      allbooks' <- retrieveAll conn :: IO [Book]+      length allbooks' `shouldBe` 1+      persist conn book {year = 1938}+      book' <- retrieveById conn (1 :: Int) :: IO (Maybe Book)+      book' `shouldBe` Just book {year = 1938}+    it "inserts Entities using Generics" $ do+      conn <- prepareDB+      allPersons <- retrieveAll conn :: IO [Person]+      length allPersons `shouldBe` 0+      insert conn person+      allPersons' <- retrieveAll conn :: IO [Person]+      length allPersons' `shouldBe` 1+      person' <- retrieveById conn (123456 :: Int) :: IO (Maybe Person)+      person' `shouldBe` Just person+    it "inserts many Entities re-using a single prepared stmt" $ do+      conn <- prepareDB+      allPersons <- retrieveAll conn :: IO [Person]+      length allPersons `shouldBe` 0+      insertMany conn manyPersons+      allPersons' <- retrieveAll conn :: IO [Person]+      length allPersons' `shouldBe` 6+    it "updates many Entities re-using a single prepared stmt" $ do+      conn <- prepareDB+      allPersons <- retrieveAll conn :: IO [Person]+      length allPersons `shouldBe` 0+      insertMany conn manyPersons+      allPersons' <- retrieveAll conn :: IO [Person]+      length allPersons' `shouldBe` 6+      let manyPersons' = map (\p -> p {name = "Bob"}) manyPersons+      updateMany conn manyPersons'+      allPersons'' <- retrieveAll conn :: IO [Person]+      all (\p -> name p == "Bob") allPersons'' `shouldBe` True+    it "inserts Entities using user implementation" $ do+      conn <- prepareDB+      allbooks <- retrieveAll conn :: IO [Book]+      length allbooks `shouldBe` 0+      insert conn book+      allbooks' <- retrieveAll conn :: IO [Book]+      length allbooks' `shouldBe` 1+      book' <- retrieveById conn (1 :: Int) :: IO (Maybe Book)+      book' `shouldBe` Just book+    it "updates Entities using Generics" $ do+      conn <- prepareDB+      insert conn person+      update conn person {name = "Bob"}+      person' <- retrieveById conn (123456 :: Int) :: IO (Maybe Person)+      person' `shouldBe` Just person {name = "Bob"}+    it "updates Entities using user implementation" $ do+      conn <- prepareDB+      insert conn book+      update conn book {title = "The Lord of the Rings"}+      book' <- retrieveById conn (1 :: Int) :: IO (Maybe Book)+      book' `shouldBe` Just book {title = "The Lord of the Rings"}+    it "deletes Entities using Generics" $ do+      conn <- prepareDB+      insert conn person+      allPersons <- retrieveAll conn :: IO [Person]+      length allPersons `shouldBe` 1+      delete conn person+      allPersons' <- retrieveAll conn :: IO [Person]+      length allPersons' `shouldBe` 0+    it "deletes Entities using user implementation" $ do+      conn <- prepareDB+      insert conn book+      allBooks <- retrieveAll conn :: IO [Book]+      length allBooks `shouldBe` 1+      delete conn book+      allBooks' <- retrieveAll conn :: IO [Book]+      length allBooks' `shouldBe` 0

@@ -1,37 +1,38 @@-{-# LANGUAGE DeriveAnyClass     #-}  -- allows automatic derivation from Entity type class+-- allows automatic derivation from Entity type class+{-# LANGUAGE DeriveAnyClass #-}+ module OneToManySpec-  ( test-  , spec-  ) where+  ( test,+    spec,+  )+where -import          Test.Hspec-import          Data.Data-import          Database.HDBC-import          Database.HDBC.Sqlite3-import          Database.GP.GenericPersistence-import          RIO    -import          Data.Maybe (fromJust)+import           Data.Maybe                     (fromJust)+import           Database.GP.GenericPersistence+import           Database.HDBC+import           Database.HDBC.Sqlite3+import           GHC.Generics+import           Test.Hspec  -- `test` is here so that this module can be run from GHCi on its own.  It is -- not needed for automatic spec discovery. (start up stack repl --test to bring up ghci and have access to all the test functions) test :: IO () test = hspec spec -withDatabase :: RIO Ctx a -> IO a-withDatabase action = do-  conn <- connectSqlite3 ":memory:"-  runGP conn $ do-    _ <- setupTableFor :: GP Article-    _ <- setupTableFor :: GP Author-    action+prepareDB :: IO Conn+prepareDB = do+  conn <- connect SQLite <$> connectSqlite3 ":memory:"+  setupTableFor @Article conn+  setupTableFor @Author conn+  return conn  data Article = Article   { articleID :: Int,     title     :: String,-    author    :: Author,+    authorId  :: Int,     year      :: Int   }-  deriving (Data, Show, Eq)+  deriving (Generic, Entity, Show, Eq) -- automatically derives Entity  data Author = Author   { authorID :: Int,@@ -39,102 +40,83 @@     address  :: String,     articles :: [Article]   }-  deriving (Data, Show, Eq)  --instance Entity Article where-  fieldsToColumns :: Article -> [(String, String)]-  fieldsToColumns _ = [("articleID", "articleID"),-                       ("title", "title"), -                       ("authorID", "authorID"),-                       ("year", "year")-                      ]--  fromRow :: [SqlValue] -> GP Article-  fromRow row = local (extendCtxCache rawArticle) $ do-    maybeAuthor <- getElseRetrieve (entityId rawAuthor)-    let author = fromJust maybeAuthor-    pure $ Article (col 0) (col 1) author (col 3)-    where-      col i = fromSql (row !! i)-      rawAuthor = (evidence :: Author) {authorID = col 2}-      rawArticle = Article (col 0) (col 1) rawAuthor (col 3)-    -  toRow a = do -    persist (author a)-    return [toSql (articleID a), toSql (title a), toSql $ authorID (author a), toSql (year a)]-+  deriving (Generic, Show, Eq)  instance Entity Author where-  fieldsToColumns :: Author -> [(String, String)]-  fieldsToColumns _ = [("authorID", "authorID"),-                       ("name", "name"), -                       ("address", "address")-                      ]+  fieldsToColumns :: [(String, String)]                  -- ommitting the articles field, +  fieldsToColumns =                                      -- as this can not be mapped to a single column+    [ ("authorID", "authorID"),+      ("name", "name"),+      ("address", "address")+    ] -  fromRow :: [SqlValue] -> GP Author-  fromRow row = local (extendCtxCache rawAuthor) $ do-    articlesByAuth <- retrieveAllWhere (idField rawAuthor) (idValue rawAuthor) :: GP [Article]-    pure $ rawAuthor {articles= articlesByAuth}+  fromRow :: Conn -> [SqlValue] -> IO Author+  fromRow conn row = do+    let authID = head row                                 -- authorID is the first column+    articlesBy <- retrieveAllWhere conn "authorId" authID -- retrieve all articles by this author+    return rawAuthor {articles = articlesBy}              -- add the articles to the author     where-      col i = fromSql (row !! i)-      rawAuthor = Author (col 0) (col 1) (col 2) []+      rawAuthor = Author (col 0) (col 1) (col 2) []       -- create the author from row (w/o articles)+      col i = fromSql (row !! i)                          -- helper function to convert SqlValue to Haskell type -  toRow :: Author -> GP [SqlValue]-  toRow a = do -    return [toSql (authorID a), toSql (name a), toSql (address a)]+  toRow :: Conn -> Author -> IO [SqlValue]+  toRow conn a = do+    mapM_ (persist conn) (articles a)                     -- persist all articles of this author (update or insert)+    return [toSql (authorID a),                           -- return the author as a list of SqlValues+            toSql (name a), toSql (address a)] + article1 :: Article-article1 = Article -  { articleID = 1, -    title = "Persistence without Boilerplate", -    author = Author -      {authorID = 1, -      name = "Max Millian", -      address = "Boston",-      articles = []}, -    year = 2018}+article1 =+  Article+    { articleID = 1,+      title = "Persistence without Boilerplate",+      authorId = 1,+      year = 2018+    }  article2 :: Article-article2 = Article -  { articleID = 2, -    title = "Boilerplate for Dummies", -    author = arthur, -    year = 2020}+article2 =+  Article+    { articleID = 2,+      title = "Boilerplate for Dummies",+      authorId = 2,+      year = 2020+    }  article3 :: Article-article3 = Article -  { articleID = 3, -    title = "The return of the boilerplate", -    author = arthur, -    year = 2022}+article3 =+  Article+    { articleID = 3,+      title = "The return of the boilerplate",+      authorId = 2,+      year = 2022+    }  arthur :: Author-arthur = Author -  {authorID = 2, -  name = "Arthur Miller", -  address = "Denver", -  articles = [article2, article3]}    +arthur =+  Author+    { authorID = 2,+      name = "Arthur Miller",+      address = "Denver",+      articles = [article2, article3]+    }  spec :: Spec spec = do   describe "Handling of 1:N References" $ do-    it "works like a charm" $ -      withDatabase $ do-        insert article1-        insert article2-        insert article3+    it "works like a charm" $ do+      conn <- prepareDB -        authors <- retrieveAll :: GP [Author]-        liftIO $ length authors `shouldBe` 2-        --liftIO $ print authors-        articles <- retrieveAll :: GP [Article]-        liftIO $ length articles `shouldBe` 3-        -        article' <- retrieveById "3" :: GP (Maybe Article)-        let art = fromJust article'-        liftIO $ (name (author art)) `shouldBe` "Arthur Miller" -        -        +      insert conn arthur+      insert conn article1 +      authors <- retrieveAll conn :: IO [Author]+      length authors `shouldBe` 1 +      articles' <- retrieveAll conn :: IO [Article]+      length articles' `shouldBe` 3 +      author2 <- retrieveById conn "2" :: IO (Maybe Author)+      fromJust author2 `shouldBe` arthur+      length (articles $ fromJust author2) `shouldBe` 2

@@ -1,28 +1,30 @@-{-# LANGUAGE DeriveAnyClass     #-}  -- allows automatic derivation from Entity type class+-- allows automatic derivation from Entity type class+{-# LANGUAGE DeriveAnyClass #-}+ module ReferenceSpec-  ( test-  , spec-  ) where+  ( test,+    spec,+  )+where -import          Test.Hspec-import          Data.Data-import          Database.HDBC-import          Database.HDBC.Sqlite3-import          Database.GP.GenericPersistence-import          RIO    +import           Data.Maybe+import           Database.GP.GenericPersistence+import           Database.HDBC+import           Database.HDBC.Sqlite3+import           GHC.Generics+import           Test.Hspec  -- `test` is here so that this module can be run from GHCi on its own.  It is -- not needed for automatic spec discovery. (start up stack repl --test to bring up ghci and have access to all the test functions) test :: IO () test = hspec spec -withDatabase :: RIO Ctx a -> IO a-withDatabase action = do-  conn <- connectSqlite3 ":memory:"-  runGP conn $ do-    _ <- setupTableFor :: GP Article-    _ <- setupTableFor :: GP Author-    action+prepareDB :: IO Conn+prepareDB = do+  conn <- connect SQLite <$> connectSqlite3 ":memory:"+  setupTableFor @Article conn+  setupTableFor @Author conn+  return conn  data Article = Article   { articleID :: Int,@@ -30,60 +32,68 @@     author    :: Author,     year      :: Int   }-  deriving (Data, Show, Eq)+  deriving (Generic, Show, Eq)  data Author = Author   { authorID :: Int,     name     :: String,     address  :: String   }-  deriving (Data, Entity, Show, Eq)  +  deriving (Generic, Entity, Show, Eq)  instance Entity Article where-  fieldsToColumns :: Article -> [(String, String)]-  fieldsToColumns _ = [("articleID", "articleID"),-                       ("title", "title"), -                       ("authorID", "authorID"),-                       ("year", "year")-                      ]+  fieldsToColumns :: [(String, String)]                      -- ommitting the author field,+  fieldsToColumns =                                          -- as this can not be mapped to a single column+    [ ("articleID", "articleID"),                            -- instead we invent a new column authorID         +      ("title", "title"),+      ("authorID", "authorID"),+      ("year", "year")+    ] -  fromRow row = do-    maybeAuthor <- retrieveById (row !! 2) :: GP (Maybe Author)-    let author = fromMaybe (error "Author not found") maybeAuthor-    pure $ Article (col 0) (col 1) author (col 3)+  fromRow :: Conn -> [SqlValue] -> IO Article+  fromRow conn row = do    +    authorById <- fromJust <$> retrieveById conn (row !! 2)  -- load author by foreign key+    return $ rawArticle {author = authorById}                -- add author to article     where-      col i = fromSql (row !! i)-      -  toRow a = do -    persist (author a)-    return [toSql (articleID a), toSql (title a), toSql $ authorID (author a), toSql (year a)]+      rawArticle = Article (col 0) (col 1)                   -- create article from row, +                           (Author (col 2) "" "") (col 3)    -- using a dummy author+        where+          col i = fromSql (row !! i) +  toRow :: Conn -> Article -> IO [SqlValue]+  toRow conn a = do+    persist conn (author a)                                  -- persist author first+    return [toSql (articleID a), toSql (title a),            -- return row for article table where +            toSql $ authorID (author a), toSql (year a)]     -- authorID is foreign key to author table +++ article :: Article-article = Article -  { articleID = 1, -    title = "Persistence without Boilerplate", -    author = arthur, -    year = 2018}-    +article =+  Article+    { articleID = 1,+      title = "Persistence without Boilerplate",+      author = arthur,+      year = 2018+    }+ arthur :: Author-arthur = Author -  {authorID = 2, -  name = "Arthur Miller", -  address = "Denver"}    +arthur =+  Author+    { authorID = 2,+      name = "Arthur Miller",+      address = "Denver"+    }  spec :: Spec spec = do   describe "Handling of 1:1 References" $ do-    it "works like a charm" $ -      withDatabase $ do-        insert article--        author' <- retrieveById "2" :: GP (Maybe Author)-        liftIO $ author' `shouldBe` Just arthur-        -        article' <- retrieveById "1" :: GP (Maybe Article)-        liftIO $ article' `shouldBe` Just article-        -+    it "works like a charm" $ do+      conn <- prepareDB+      insert conn article +      author' <- retrieveById conn "2" :: IO (Maybe Author)+      author' `shouldBe` Just arthur +      article' <- retrieveById conn "1" :: IO (Maybe Article)+      article' `shouldBe` Just article

@@ -1,2 +1,4 @@-{-# OPTIONS_GHC -Wno-missing-export-lists #-} -- Avoid warning for missing export list in test/Spec.hs-{-# OPTIONS_GHC -F -pgmF hspec-discover   #-} -- this compiler pragma allows GHC to automatically discover all Hspec Test Specs.+-- this compiler pragma allows GHC to automatically discover all Hspec Test Specs.+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}+-- Avoid warning for missing export list in test/Spec.hs+{-# OPTIONS_GHC -Wno-missing-export-lists #-}