packages feed

generic-persistence (empty) → 0.2.0.0

raw patch · 17 files changed

+1944/−0 lines, 17 filesdep +HDBCdep +HDBC-sqlite3dep +QuickChecksetup-changed

Dependencies added: HDBC, HDBC-sqlite3, QuickCheck, base, bytestring, convertible, exceptions, generic-persistence, ghc, ghc-prim, hspec, hspec-discover, rio, syb, text, time, transformers

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Author name here (c) 2022++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Author name here nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,372 @@+# GenericPersistence - A Haskell persistence layer using Generics and Reflection++![GP Logo](gp-logo-300.png)++## 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`).++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*).++That is, it provides means for inserting, updating, deleting and quering such enties to/from relational databases.++The main *design goal* is to minimize the *boilerplate* code required:++- no manual instantiation of type classes+- no implementation of encoders/decoders+- no special naming convention for types and their attributes +- no special types to define entities and attributes+- no Template Haskell scaffolding of glue code++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:++- A query language+- Handling of nested transactions+- Handling auto-incrementing primary keys+- ...+++## 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 #-}++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)+++-- | An Entity data type with several fields, using record syntax.+data Person = Person+  { personID :: Int,+    name     :: String,+    age      :: Int,+    address  :: String+  }+  deriving (Data, Entity, Show) -- deriving Entity allows to handle the type with GenericPersistence++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"++  -- 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"++  -- 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 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)]++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"}++    -- select a Person from a database+    alice' <- retrieveById (123456 :: Int) :: GP (Maybe Person)+    liftIO $ print alice'++    -- select all Persons from the database+    allPersons <- retrieveAll :: GP [Person]+    liftIO $ print allPersons++    -- delete a Person+    delete alice++    -- select all Persons from a database. The deleted Person is not in the result.+    allPersons' <- retrieveAll :: GP [Person]+    liftIO $ 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 book+    insert book2+    allBooks <- retrieveAll :: GP [Book]+    liftIO $ print allBooks++    -- explicitly updating a Book+    update book2 {title = "The Lord of the Rings"}+    delete book++    allBooks' <- retrieveAll :: GP [Book]+    liftIO $ print allBooks'+```++## Handling enumeration fields++Say we have a data type `Book` with an enumeration field of type `BookCategory`:++```haskell+data Book = Book+  { bookID :: Int,+    title   :: String,+    author  :: String,+    year    :: Int,+    category :: BookCategory+  }+  deriving (Data, 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)]+```++`toSql` and `fromSql` expect `Convertible` instances as arguments. This works for `BookCatagory` as GenericPersistence provides `Convertible` instances for all `Enum` types.++If you do not want to use `Enum` types for your enumeration fields, you can implement `Convertible` instances for your own types:++```haskell+data BookCategory = Fiction | Travel | Arts | Science | History | Biography | Other+  deriving (Data, Show, Read)++instance Convertible BookCategory SqlValue where+  safeConvert = Right . toSql . show+  +instance Convertible SqlValue BookCategory where+  safeConvert = Right . read . fromSql  +```++## Handling embedded Objects++Say we have a data type `Article` with an field of type `Author`:++```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+  }+  deriving (Data, 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:++```haskell+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"),+                       ("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)+    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)]+    where +      authID = authorID (author a)+      authorName = name (author a)+      authorAddress = address (author a)+```++## Handling 1:1 references++If we have the same data types as in the previous example, but we want to store the `Author` in a separate table, we can use the following approach:++```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+  }+  deriving (Data, Entity, Show, Eq)  -- we derive Entity for Author++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")+                      ]++  -- 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)+    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)]++```+## Handling 1:n references++Now let's extend the previous example by also having a list of Àrticle`s 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.++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. ++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.++We can handle this situation by using the following approach:++```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")+                      ]++  -- 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)+    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)]+++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")+                      ]++  -- 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) []++  -- 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)]+```++## Todo++- coding free support for 1:1 and 1:n relationships+- coding free support for Enums+- resolution cache with proper Map+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,133 @@+-- allows automatic derivation from Entity type class+{-# LANGUAGE DeriveAnyClass #-}++module Main (main, main1) 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)++-- | An Entity data type with several fields, using record syntax.+data Person = Person+  { personID :: Int,+    name     :: String,+    age      :: Int,+    address  :: String+  }+  deriving (Data, Entity, Show) -- deriving Entity allows to handle the type with GenericPersistence++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"++  -- 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"++  -- 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 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)]++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"}++    -- select a Person from a database+    alice' <- retrieveById (123456 :: Int) :: GP (Maybe Person)+    liftIO $ print alice'++    -- select all Persons from the database+    allPersons <- retrieveAll :: GP [Person]+    liftIO $ print allPersons++    -- delete a Person+    delete alice++    -- select all Persons from a database. The deleted Person is not in the result.+    allPersons' <- retrieveAll :: GP [Person]+    liftIO $ 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 book+    insert book2+    allBooks <- retrieveAll :: GP [Book]+    liftIO $ print allBooks++    -- explicitly updating a Book+    update book2 {title = "The Lord of the Rings"}+    delete book++    allBooks' <- retrieveAll :: GP [Book]+    liftIO $ print allBooks'++  -- close connection+  disconnect conn++main1 :: IO ()+main1 = do+  -- connect to a database+  conn <- connectSqlite3 "sqlite.db"+  runGP conn $ do+    -- initialize Person table+    _ <- setupTableFor :: GP Person++    -- create a Person entity+    let alice = Person {personID = 123456, name = "Alice", age = 25, address = "Elmstreet 1"}++    -- insert a Person into a database+    persist alice++    -- update a Person+    persist alice {address = "Main Street 200"}++    -- 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'++    alice'' <- retrieveById "123456" :: GP (Maybe Person)++    liftIO $ print alice''++    -- delete a Person from a database+    delete alice++  -- close connection+  disconnect conn
+ generic-persistence.cabal view
@@ -0,0 +1,119 @@+cabal-version:      1.12+name:               generic-persistence+version:            0.2.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+homepage:           https://github.com/githubuser/generic-persistence#readme+bug-reports:        https://github.com/githubuser/generic-persistence/issues+synopsis:           Database persistence using generics+description:+    Please see the README on GitHub at <https://github.com/githubuser/generic-persistence#readme>++category:           Database+build-type:         Simple+extra-source-files: README.md++source-repository head+    type:     git+    location: https://github.com/githubuser/generic-persistence++library+    exposed-modules:+        Database.GP+        Database.GP.Entity+        Database.GP.GenericPersistence+        Database.GP.RecordtypeReflection+        Database.GP.SqlGenerator+        Database.GP.TypeInfo++    hs-source-dirs:   src+    other-modules:    Paths_generic_persistence+    default-language: GHC2021+    ghc-options:+        -Wall -Wcompat -Widentities -Wincomplete-record-updates+        -Wincomplete-uni-patterns -Wmissing-export-lists+        -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints++    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++executable generic-persistence-demo+    main-is:          Main.hs+    hs-source-dirs:   app+    other-modules:    Paths_generic_persistence+    default-language: GHC2021+    ghc-options:+        -Wall -Wcompat -Widentities -Wincomplete-record-updates+        -Wincomplete-uni-patterns -Wmissing-export-lists+        -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints+        -threaded -rtsopts -with-rtsopts=-N++    build-depends:+        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++test-suite generic-persistence-test+    type:             exitcode-stdio-1.0+    main-is:          Spec.hs+    hs-source-dirs:   test+    other-modules:+        EmbeddedSpec+        EnumSpec+        GenericPersistenceSpec+        OneToManySpec+        ReferenceSpec+        Paths_generic_persistence++    default-language: GHC2021+    ghc-options:+        -Wall -Wcompat -Widentities -Wincomplete-record-updates+        -Wincomplete-uni-patterns -Wmissing-export-lists+        -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints+        -threaded -rtsopts -with-rtsopts=-N++    build-depends:+        HDBC <2.5,+        HDBC-sqlite3 <2.4,+        QuickCheck <2.15,+        base >=4.7 && <5,+        bytestring <0.12,+        convertible <1.2,+        exceptions <0.11,+        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
+ src/Database/GP.hs view
@@ -0,0 +1,37 @@+module Database.GP   ( retrieveById,+    retrieveAll,+    retrieveAllWhere,+    persist,+    insert,+    update,+    delete,+    setupTableFor,+    idValue,+    Entity (..),+    columnNameFor,+    fieldTypeFor,+    maybeFieldTypeFor,+    toString,+    evidence,+    evidenceFrom,+    ResolutionCache,+    EntityId,+    entityId,+    getElseRetrieve,+    TypeInfo (..),+    typeInfoFromContext,+    typeInfo,+    Ctx (..),+    GP,+    extendCtxCache,+    runGP,+    liftIO,+    local,+    ask,+  )+where++-- We are just re-exporting the functions from the GenericPersistence module.  +import           Database.GP.GenericPersistence++
+ src/Database/GP/Entity.hs view
@@ -0,0 +1,146 @@+{-# LANGUAGE DefaultSignatures #-}++module Database.GP.Entity+  ( Entity (..),+    columnNameFor,+    fieldTypeFor,+    maybeFieldTypeFor,+    toString,+    evidence,+    evidenceFrom,+    ResolutionCache,+    EntityId,+    Ctx (..),+    GP,+  )+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++{--+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 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 +- 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, +but that are not explicitely encoded in the type class definition:++- The type must be a product type in record notation.+- The type must have exactly one constructor.+- There must be single primary key field, compund primary keys are not supported.++--}++class (Data a) => Entity a where+  -- | Converts a database row to a value of type 'a'.+  fromRow :: [SqlValue] -> GP a++  -- | Converts a value of type 'a' to a database row.+  toRow :: a -> GP [SqlValue]++  -- | Returns the name of the primary key field for a type 'a'.+  idField :: a -> String++  -- | Returns a list of tuples that map field names to column names for a type 'a'.+  fieldsToColumns :: a -> [(String, String)]++  -- | Returns the name of the table for a type 'a'.+  tableName :: a -> String++  -- | generic default implementation+  default fromRow :: [SqlValue] -> GP a+  fromRow = pure . gFromRow++  -- | generic default implementation+  default toRow :: a -> GP [SqlValue]+  toRow = pure . gToRow++  -- | 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+    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+    }++type GP = RIO Ctx++-- | 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)++-- | 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)]++-- | 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+    Just columnName -> columnName+    Nothing -> error ("columnNameFor: " ++ toString x ++ +                      " 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)++maybeFieldTypeFor :: Entity a => a -> String -> Maybe TypeRep+maybeFieldTypeFor a 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+  where+    mappedRow = map fromSql (gToRow x)++-- | 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+++evidenceFrom :: forall a. (Entity a) => TypeInfo a -> a+evidenceFrom = fromConstr . typeConstructor
+ src/Database/GP/GenericPersistence.hs view
@@ -0,0 +1,193 @@+{-# OPTIONS_GHC -Wno-orphans #-}+module Database.GP.GenericPersistence+  ( retrieveById,+    retrieveAll,+    retrieveAllWhere,+    persist,+    insert,+    update,+    delete,+    setupTableFor,+    idValue,+    Entity (..),+    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           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++{--+ This module defines RDBMS Persistence operations for Record Data Types that are instances of 'Data'.+ I call instances of such a data type Entities.++ The Persistence operations are using Haskell generics to provide compile time reflection capabilities.+ 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]+  case resultRowsSqlValues of+    []          -> pure Nothing+    [singleRow] -> Just <$> fromRow singleRow+    _ -> error $ "More than one" ++ show (typeConstructor ti) ++ " found for id " ++ show eid+  where+    ti = typeInfoFromContext :: TypeInfo a+    stmt = selectStmtFor ti+    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+  where+    ti = typeInfoFromContext :: TypeInfo a+    stmt = selectAllStmtFor ti ++retrieveAllWhere :: forall a. (Entity a) => String -> SqlValue -> GP [a]+retrieveAllWhere field val = do+  conn <- askConnection+  resultRows <- liftIO $ quickQuery conn stmt [val]+  mapM fromRow resultRows+  where+    ti = typeInfoFromContext :: TypeInfo a+    stmt = selectAllWhereStmtFor ti field++-- | 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]+  case resultRows of+    []           -> insert entity+    [_singleRow] -> update entity+    _            -> error $ "More than one entity found for id " ++ show eid+  where+    ti = typeInfo entity+    eid = idValue entity+    preparedSelectStmt = selectStmtFor ti++-- | 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+++-- | 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)+++extendCtxCache :: Entity a => a -> Ctx -> Ctx+extendCtxCache x (Ctx conn rc) = Ctx conn (cacheEntry : rc)+  where+    cacheEntry = (entityId x, toDyn x)+++-- | 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)++-- | 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++askCache :: GP ResolutionCache+askCache = cache <$> ask++runGP :: (MonadIO m, IConnection conn) => conn -> RIO Ctx a -> m a+runGP conn = runRIO (Ctx (ConnWrapper conn) mempty)++-- 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+  safeConvert :: SqlValue -> ConvertResult a+  safeConvert = Right . toEnum . fromSql++instance {-# OVERLAPS #-} forall a . (Enum a) => Convertible a SqlValue where+  safeConvert :: a -> ConvertResult SqlValue+  safeConvert = Right . toSql . fromEnum
+ src/Database/GP/RecordtypeReflection.hs view
@@ -0,0 +1,146 @@+{-# 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"
+ src/Database/GP/SqlGenerator.hs view
@@ -0,0 +1,137 @@+module Database.GP.SqlGenerator+  ( insertStmtFor,+    updateStmtFor,+    selectStmtFor,+    deleteStmtFor,+    selectAllStmtFor,+    selectAllWhereStmtFor,+    createTableStmtFor,+    dropTableStmtFor,+  )+where++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 =+  "INSERT INTO "+    ++ tableName x+    ++ " ("+    ++ intercalate ", " columns+    ++ ") VALUES ("+    ++ intercalate ", " (params (length columns))+    ++ ");"+  where+    columns = columnNamesFor x+++columnNamesFor :: Entity a => a -> [String]+columnNamesFor x =  map snd fieldColumnPairs+  where+    fieldColumnPairs = fieldsToColumns x +++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 =+  "UPDATE "+    ++ tableName x+    ++ " SET "+    ++ intercalate ", " updatePairs+    ++ " WHERE "+    ++ idColumn x+    ++ " = ?"+    ++ ";"+  where+    updatePairs = map (++ " = ?") (columnNamesFor x)++idColumn :: Entity a => a -> String+idColumn x = columnNameFor x (idField x)++-- | 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 =+  "SELECT "+    ++ intercalate ", " (columnNamesFor x)+    ++ " FROM "+    ++ tableName x+    ++ " WHERE "+    ++ idColumn x+    ++ " = ?;"+  where+    x = evidenceFrom ti :: a++selectAllStmtFor :: forall a. (Entity a) => TypeInfo a -> String+selectAllStmtFor ti =+  "SELECT "+    ++ intercalate ", " (columnNamesFor x)+    ++ " FROM "+    ++ tableName x+    ++ ";"+  where+    x = evidenceFrom ti :: a++selectAllWhereStmtFor :: forall a. (Entity a) => TypeInfo a -> String -> String+selectAllWhereStmtFor ti field =+  "SELECT "+    ++ intercalate ", " (columnNamesFor x)+    ++ " FROM "+    ++ tableName x+    ++ " WHERE "+    ++ column+    ++ " = ?;"+  where+    x = evidenceFrom ti :: a+    column = columnNameFor x field++deleteStmtFor :: Entity a => a -> String+deleteStmtFor x =+  "DELETE FROM "+    ++ tableName x+    ++ " WHERE "+    ++ idColumn x+    ++ " = ?;"++createTableStmtFor :: forall a. (Entity a) => TypeInfo a -> String+createTableStmtFor ti =+  "CREATE TABLE "+    ++ tableName x+    ++ " ("+    ++ intercalate ", " (map (\(f,c) -> c ++ " " ++ columnTypeFor x f ++ optionalPK f) (fieldsToColumns x))+    ++ ");"+  where+    x = evidenceFrom ti :: a+    isIdField f = f == idField x+    optionalPK f = if isIdField f then " PRIMARY KEY" else ""+    +    +columnTypeFor :: forall a. (Entity a) => a -> String -> String+columnTypeFor x field = +  case fType of+    "Int" -> "INTEGER"+    "String" -> "TEXT"+    "Double" -> "REAL"+    "Float" -> "REAL"+    "Bool" -> "INT"+    _ -> "TEXT"+    where+      maybeFType = maybeFieldTypeFor x field+      fType = maybe "OTHER" show maybeFType+++dropTableStmtFor :: forall a. (Entity a) => TypeInfo a -> String+dropTableStmtFor ti =+  "DROP TABLE IF EXISTS "+    ++ tableName x+    ++ ";"+  where+    x = evidenceFrom ti :: a
+ src/Database/GP/TypeInfo.hs view
@@ -0,0 +1,71 @@+--{-# LANGUAGE RankNTypes           #-}+--{-# LANGUAGE ScopedTypeVariables  #-}+module Database.GP.TypeInfo+  ( TypeInfo,+    typeConstructor,+    fieldNames,+    fieldTypes,+    typeName,+    typeInfo,+    typeInfoFromContext,+  )+where++import Data.Data++-- | 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,+    fieldNames      :: [String],+    fieldTypes      :: [TypeRep]+  }+  deriving (Show)++-- | this function is a smart constructor for TypeInfo objects.+--   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+    { typeConstructor = ensureSingleConstructor (dataTypeOf x),+      fieldNames = fieldNamesOf x,+      fieldTypes = gmapQ typeOf x+    }++-- | 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 ++ ")"++-- | 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++-- | This function returns the (unqualified) type name of `a` from a `TypeInfo a` object.+typeName :: TypeInfo a -> String+typeName = dataTypeName . constrType . typeConstructor++-- | 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"
+ test/EmbeddedSpec.hs view
@@ -0,0 +1,83 @@+module EmbeddedSpec+  ( test+  , spec+  ) where++import          Test.Hspec+import          Data.Data+import          Database.HDBC+import          Database.HDBC.Sqlite3+import          Database.GP.GenericPersistence+import          RIO    ++-- `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++data Article = Article+  { articleID :: Int,+    title     :: String,+    author    :: Author,+    year      :: Int+  }+  deriving (Data, Show, Eq)++data Author = Author+  { authorID :: Int,+    name     :: String,+    address  :: String+  }+  deriving (Data, Show, Eq)  ++instance Entity Article where++  fieldsToColumns :: Article -> [(String, String)]+  fieldsToColumns _ = [("articleID", "articleID"),+                       ("title", "title"), +                       ("authorID", "authorID"), +                       ("authorName", "authorName"), +                       ("authorAddress", "authorAddress"),+                       ("year", "year")+                      ]++  fromRow row = return $ 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)++article :: Article+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]++
+ test/EnumSpec.hs view
@@ -0,0 +1,60 @@+module EnumSpec+  ( test+  , spec+  ) where++import          Test.Hspec+import          Data.Data+import          Database.HDBC+import          Database.HDBC.Sqlite3+import          Database.GP.GenericPersistence+import          RIO    ++-- `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++data Book = Book+  { bookID :: Int,+    title   :: String,+    author  :: String,+    year    :: Int,+    category :: BookCategory+  }+  deriving (Data, Show, Eq)++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)++  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 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]++
+ test/GenericPersistenceSpec.hs view
@@ -0,0 +1,184 @@+{-# LANGUAGE DeriveAnyClass     #-}  -- allows automatic derivation from Entity type class+module GenericPersistenceSpec+  ( test+  , spec+  , withDatabase+  ) where+++import           Test.Hspec+import           Data.Data             +import           Database.HDBC         +import           Database.HDBC.Sqlite3+import           Database.GP.GenericPersistence+import           RIO++++-- `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++-- | A data type with several fields, using record syntax.+data Person = Person+  { personID :: Int,+    name     :: String,+    age      :: Int,+    address  :: String+  }+  deriving (Data, Entity, Show, Eq)++data Book = Book+  { book_id :: Int,+    title   :: String,+    author  :: String,+    year    :: Int,+    category :: BookCategory+  }+  deriving (Data, Show, Eq)++data BookCategory = Fiction | Travel | Arts | Science | History | Biography | Other+  deriving (Data, 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)+    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)]+++person :: Person+person = Person 123456 "Alice" 25 "123 Main 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+      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+
+ test/OneToManySpec.hs view
@@ -0,0 +1,140 @@+{-# LANGUAGE DeriveAnyClass     #-}  -- allows automatic derivation from Entity type class+module OneToManySpec+  ( 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)++-- `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++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)  ++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)]+++instance Entity Author where+  fieldsToColumns :: Author -> [(String, String)]+  fieldsToColumns _ = [("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}+    where+      col i = fromSql (row !! i)+      rawAuthor = Author (col 0) (col 1) (col 2) []++  toRow :: Author -> GP [SqlValue]+  toRow a = do +    return [toSql (authorID a), 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}++article2 :: Article+article2 = Article +  { articleID = 2, +    title = "Boilerplate for Dummies", +    author = arthur, +    year = 2020}++article3 :: Article+article3 = Article +  { articleID = 3, +    title = "The return of the boilerplate", +    author = arthur, +    year = 2022}++arthur :: Author+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++        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" +        +        +++
+ test/ReferenceSpec.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE DeriveAnyClass     #-}  -- allows automatic derivation from Entity type class+module ReferenceSpec+  ( test+  , spec+  ) where++import          Test.Hspec+import          Data.Data+import          Database.HDBC+import          Database.HDBC.Sqlite3+import          Database.GP.GenericPersistence+import          RIO    ++-- `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++data Article = Article+  { articleID :: Int,+    title     :: String,+    author    :: Author,+    year      :: Int+  }+  deriving (Data, Show, Eq)++data Author = Author+  { authorID :: Int,+    name     :: String,+    address  :: String+  }+  deriving (Data, Entity, Show, Eq)  ++instance Entity Article where+  fieldsToColumns :: Article -> [(String, String)]+  fieldsToColumns _ = [("articleID", "articleID"),+                       ("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)+    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)]++article :: Article+article = Article +  { articleID = 1, +    title = "Persistence without Boilerplate", +    author = arthur, +    year = 2018}+    +arthur :: Author+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+        +++
+ test/Spec.hs view
@@ -0,0 +1,2 @@+{-# 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.