Fix accidental FromDbValues instances

Author: jerbaroo

README.md

@@ -5,8 +5,9 @@ Database-agnostic interface to generically persisted data.
 ## Introduction
 
 Explanation of the above:
-- Database-agnostic interface: the interface is called `MonadDb`, and you must
-  specify how it can communicate with your database (e.g. PostgreSQL server).
+- Database-agnostic interface: the typeclass is called `MonadDb`, and you must
+  specify how it can communicate with your database (we provide an example for
+  connecting to a PostgreSQL server).
 - Generically persisted data: you can derive the necessary instances for your
   data types via `Generics`. This will enable `MonadDb` to read/write instances
   of your data types to/from your database.

database-generic/src/Database/Generic/Entity/DbTypes.hs

@@ -5,12 +5,12 @@ module Database.Generic.Entity.DbTypes where
 import Data.Aeson qualified as Aeson
 import Data.ByteString (ByteString)
 import Data.ByteString.Char8 qualified as BS
-import Database.Generic.Entity.FromDb (FromDbValues(..))
 import Database.Generic.Prelude
 import Database.HDBC qualified as HDBC
 
 data DbT f
-  = DbBytes   !(F f Bytes)
+  = DbBool    !(F f Bool)
+  | DbBytes   !(F f Bytes)
   | DbInt64   !(F f Int64)
   | DbInteger !(F f Integer)
   | DbString  !(F f String)
@@ -32,6 +32,9 @@ deriving instance Show           (DbT Unit)
 class HasDbType a where
   dbType :: DbType
 
+instance HasDbType Bool where
+  dbType = DbBool Unit
+
 instance HasDbType Int64 where
   dbType = DbInt64 Unit
 
@@ -46,20 +49,12 @@ deriving instance Aeson.ToJSON   (DbT Id)
 deriving instance Eq             (DbT Id)
 deriving instance Show           (DbT Id)
 
-instance From Int64 DbValue  where from = DbInt64
+instance From Bool   DbValue where from = DbBool
+instance From Int64  DbValue where from = DbInt64
 instance From String DbValue where from = DbString
 
-instance FromDbValues DbValue Int64 where
-  fromDbValues [DbInt64   i] = i
-  fromDbValues [DbInteger i] = unsafeFrom i
-  fromDbValues x = error $ "Error constructing Int64 from " <> show x
-
-instance FromDbValues DbValue String where
-  fromDbValues [DbBytes  b] = from b
-  fromDbValues [DbString s] = s
-  fromDbValues x = error $ "Error constructing Int64 from " <> show x
-
 instance From HDBC.SqlValue DbValue where
+  from (HDBC.SqlBool       b) = DbBool b
   from (HDBC.SqlString     s) = DbString s
   from (HDBC.SqlByteString b) = DbBytes $ Bytes b
   from (HDBC.SqlInt64      i) = DbInt64 i

database-generic/src/Database/Generic/Entity/FromDb.hs

@@ -3,6 +3,8 @@
 module Database.Generic.Entity.FromDb where
 
 import Database.Generic.Prelude
+import Database.Generic.Entity.DbColumns (HasDbColumns)
+import Database.Generic.Entity.DbTypes (DbT(..), DbValue)
 import Generics.Eot qualified as G
 
 data FromDbError dbv
@@ -17,7 +19,26 @@ instance (Show dbv, Typeable dbv) => Exception (FromDbError dbv)
 class FromDbValues dbv a where
   fromDbValues :: [dbv] -> a
 
-instance {-# OVERLAPPABLE #-} (G.HasEot a, GFromDbValues dbv (G.Eot a)) => FromDbValues dbv a where
+instance FromDbValues DbValue Bool where
+  fromDbValues [DbBool b] = b
+  fromDbValues x = error $ "Error constructing Bool from " <> show x
+
+instance FromDbValues DbValue Int64 where
+  fromDbValues [DbInt64   i] = i
+  fromDbValues [DbInteger i] = unsafeFrom i
+  fromDbValues x = error $ "Error constructing Int64 from " <> show x
+
+instance FromDbValues DbValue String where
+  fromDbValues [DbBytes  b] = from b
+  fromDbValues [DbString s] = s
+  fromDbValues x = error $ "Error constructing Int64 from " <> show x
+
+instance {-# OVERLAPPABLE #-}
+  ( G.HasEot a
+  , GFromDbValues dbv (G.Eot a)
+  , HasDbColumns a -- Only included to ensure that 'FromDbValues' instances aren't
+                   -- derived for simple datatypes such as 'Bool'.
+  ) => FromDbValues dbv a where
   fromDbValues = G.fromEot . gFromDbValues
 
 -- | Typeclass for generic implementation of 'FromDbValues'.

database-generic/src/Database/Generic/Entity/ToDb.hs

@@ -2,6 +2,7 @@
 
 module Database.Generic.Entity.ToDb where
 
+import Database.Generic.Entity.DbColumns (HasDbColumns)
 import Database.Generic.Entity.DbTypes (DbValue)
 import Database.Generic.Prelude
 import Generics.Eot qualified as G
@@ -21,7 +22,12 @@ instance {-# OVERLAPPABLE #-} From a DbValue => ToDbValue a where
 class ToDbValues a where
   toDbValues :: a -> [DbValue]
 
-instance {-# OVERLAPPABLE #-} (G.HasEot a, GToDbValues (G.Eot a)) => ToDbValues a where
+instance {-# OVERLAPPABLE #-}
+  ( G.HasEot a
+  , GToDbValues (G.Eot a)
+  , HasDbColumns a -- Only included to ensure that 'ToDbValues' instances aren't
+                   -- derived for simple datatypes such as 'Bool'.
+  ) => ToDbValues a where
   toDbValues = gToDbValues . G.toEot
 
 -- | Typeclass for generic implementation of 'ToDbValues'.

database-generic/src/Database/Generic/Serialize.hs

@@ -11,12 +11,14 @@ class Serialize a db where
   serialize :: a -> String
 
 instance Serialize DbType PostgreSQL where
+  serialize (DbBool    Unit) = "BOOLEAN"
   serialize (DbBytes   Unit) = "BINARY"
   serialize (DbInt64   Unit) = "BIGINT"
   serialize (DbInteger Unit) = "BIGINT"
   serialize (DbString  Unit) = "VARCHAR"
 
 instance Serialize DbValue PostgreSQL where
+  serialize (DbBool    b)  = show b
   serialize (DbBytes   b)  = show b
   serialize (DbInt64   i)  = show i
   serialize (DbInteger i)  = show i

tutorial/tutorial/Main.hs

@@ -25,7 +25,7 @@ import GHC.Generics (Generic)
 import Witch (from)
 
 -- | Data type we want to persist.
-data Person = Person { age :: !Int64, name :: !String }
+data Person = Person { age :: !Int64, name :: !String, ownsDog :: !(Bool) }
   deriving (Generic, PrimaryKey "name", Show)
 
 -- | Connection string to access our PostgreSQL DB.
@@ -68,24 +68,30 @@ instance MonadDbNewConn AppM PSQL.Connection where
 main :: IO ()
 main = do
   let c        = connStr "127.0.0.1" 5432 "postgres" "demo" "demo"
-  let john     = Person 70 "John"
+  let john     = Person 70 "John" False
   let info m s = do
         putStrLn $ "\n" <> m
         print =<< runAppM c (tx $ execute s)
 
   info "Create table if not exists" $ createTable @Person True
   info "Delete all" $ deleteAll @Person -- Clear table before tutorial.
 
-  info "Insert one" $ returning $ insertOne $ john
+  let x = returning $ insertOne john -- Insert One (Just Person) Person
+  --
+  -- HasOutputType (Insert o (Just Person) a) where
+  --   outputType = OutputTypeRows
+  --
+  -- ParseOutput DbValue s where
+  info "Insert one" x
 
   info "Insert many" $
-    insertMany [Person 25 "Alice", Person 25 "Bob"]
+    insertMany [Person 25 "Alice" True, Person 25 "Bob" False]
 
   info "Insert many, returning" $
-    returning $ insertMany [Person 26 "Charlie", Person 26 "Dee"]
+    returning $ insertMany [Person 26 "Charlie" False, Person 26 "Dee" True]
 
   info "Insert many, returning age" $
-    insertMany [Person 27 "Enid", Person 27 "Flavio"] ==> field @"age"
+    insertMany [Person 27 "Enid" False, Person 27 "Flavio" True] ==> field @"age"
 
   info "Select all" $ selectAll @Person