From 5bebb26fb7599f5d036434e5bcd0a50c99c53736 Mon Sep 17 00:00:00 2001
From: Oleg Grenrus <oleg.grenrus@iki.fi>
Date: Sun, 15 Nov 2020 21:23:35 +0200
Subject: [PATCH] Add Newtypes module

---
 CHANGES.md                                 |  3 ++
 postgresql-simple.cabal                    |  1 +
 src/Database/PostgreSQL/Simple/Newtypes.hs | 49 ++++++++++++++++++++++
 test/Main.hs                               | 45 ++++++++++++++++++++
 4 files changed, 98 insertions(+)
 create mode 100644 src/Database/PostgreSQL/Simple/Newtypes.hs

diff --git a/CHANGES.md b/CHANGES.md
index e0fed35..9588f7d 100644
--- a/CHANGES.md
+++ b/CHANGES.md
@@ -16,6 +16,9 @@
   * Fix spurious aborts when retrying transactions
     Thanks to Elliot Cameron for the implementation
     https://github.com/haskellari/postgresql-simple/pull/34
+  * Add `Database.PostgreSQL.Simple.Newtypes` module
+    with `Aeson` newtype.
+    https://github.com/haskellari/postgresql-simple/pull/55
 
 ### Version 0.6.2 (2019-04-26)
   
diff --git a/postgresql-simple.cabal b/postgresql-simple.cabal
index 3aadb77..ec93c76 100644
--- a/postgresql-simple.cabal
+++ b/postgresql-simple.cabal
@@ -48,6 +48,7 @@ library
     Database.PostgreSQL.Simple.HStore.Internal
     Database.PostgreSQL.Simple.Internal
     Database.PostgreSQL.Simple.LargeObjects
+    Database.PostgreSQL.Simple.Newtypes
     Database.PostgreSQL.Simple.Notification
     Database.PostgreSQL.Simple.Ok
     Database.PostgreSQL.Simple.Range
diff --git a/src/Database/PostgreSQL/Simple/Newtypes.hs b/src/Database/PostgreSQL/Simple/Newtypes.hs
new file mode 100644
index 0000000..1978db6
--- /dev/null
+++ b/src/Database/PostgreSQL/Simple/Newtypes.hs
@@ -0,0 +1,49 @@
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+-- | Module with newtypes suitable to usage with @DerivingVia@ or standalone.
+--
+-- The newtypes are named after packages they wrap.
+module Database.PostgreSQL.Simple.Newtypes (
+    Aeson (..), getAeson,
+) where
+
+import Data.Typeable (Typeable)
+import Database.PostgreSQL.Simple.ToField (ToField (..))
+import Database.PostgreSQL.Simple.FromField (FromField (..), fromJSONField)
+
+import qualified Data.Aeson as Aeson
+
+-------------------------------------------------------------------------------
+-- aeson
+-------------------------------------------------------------------------------
+
+-- | A newtype wrapper with 'ToField' and 'FromField' instances
+-- based on 'Aeson.ToJSON' and 'Aeson.FromJSON' type classes from @aeson@.
+--
+-- Example using @DerivingVia@:
+--
+-- @
+-- data Foo = Foo Int String
+--   deriving stock (Eq, Show, Generic)            -- GHC built int
+--   deriving anyclass ('Aeson.FromJSON', 'Aeson.ToJSON')          -- Derived using GHC Generics
+--   deriving ('ToField', 'FromField') via 'Aeson' Foo   -- DerivingVia
+-- @
+--
+-- Example using 'Aeson' newtype directly, for more ad-hoc queries
+--
+-- @
+-- execute conn "INSERT INTO tbl (fld) VALUES (?)" (Only ('Aeson' x))
+-- @
+--  
+--  @since 0.6.3
+newtype Aeson a = Aeson a
+  deriving (Eq, Show, Read, Typeable, Functor)
+
+getAeson :: Aeson a -> a
+getAeson (Aeson a) = a
+
+instance Aeson.ToJSON a => ToField (Aeson a) where
+    toField = toField . Aeson.encode . getAeson
+
+instance (Aeson.FromJSON a, Typeable a) => FromField (Aeson a) where
+    fromField f bs = fmap Aeson (fromJSONField f bs)
diff --git a/test/Main.hs b/test/Main.hs
index e074a15..ed40d4d 100644
--- a/test/Main.hs
+++ b/test/Main.hs
@@ -3,10 +3,19 @@
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE DoAndIfThenElse #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+#if __GLASGOW_HASKELL__ >= 806
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE DeriveAnyClass #-}
+#endif
+module Main (main) where
+
 import Common
 import Database.PostgreSQL.Simple.Copy
+import Database.PostgreSQL.Simple.ToField (ToField)
 import Database.PostgreSQL.Simple.FromField (FromField)
 import Database.PostgreSQL.Simple.HStore
+import Database.PostgreSQL.Simple.Newtypes
 import Database.PostgreSQL.Simple.Internal (breakOnSingleQuestionMark)
 import Database.PostgreSQL.Simple.Types(Query(..),Values(..), PGArray(..))
 import qualified Database.PostgreSQL.Simple.Transaction as ST
@@ -59,6 +68,8 @@ tests env = testGroup "tests"
     , testCase "HStore"               . testHStore
     , testCase "citext"               . testCIText
     , testCase "JSON"                 . testJSON
+    , testCase "Aeson newtype"        . testAeson
+    , testCase "DerivingVia"          . testDerivingVia
     , testCase "Question mark escape" . testQM
     , testCase "Savepoint"            . testSavepoint
     , testCase "Unicode"              . testUnicode
@@ -240,6 +251,40 @@ testJSON TestEnv{..} = do
       js' <- query conn "SELECT ?::json" js
       [js] @?= js'
 
+testAeson :: TestEnv -> Assertion
+testAeson TestEnv{..} = do
+    roundTrip (Map.fromList [] :: Map Text Text)
+    roundTrip (Map.fromList [("foo","bar"),("bar","baz"),("baz","hello")] :: Map Text Text)
+    roundTrip (Map.fromList [("fo\"o","bar"),("b\\ar","baz"),("baz","\"value\\with\"escapes")] :: Map Text Text)
+    roundTrip (V.fromList [1,2,3,4,5::Int])
+    roundTrip ("foo" :: Text)
+    roundTrip (42 :: Int)
+  where
+    roundTrip :: (Eq a, Show a, Typeable a, ToJSON a, FromJSON a)=> a -> Assertion
+    roundTrip x = do
+      y <- query conn "SELECT ?::json" (Only (Aeson x))
+      [Only (Aeson x)] @?= y
+
+testDerivingVia :: TestEnv -> Assertion
+testDerivingVia TestEnv{..} = do
+#if __GLASGOW_HASKELL__ <806
+    return ()
+#else
+    roundTrip $ DerivingVia1 42 "Meaning of Life"
+  where
+    roundTrip :: (Eq a, Show a, Typeable a, ToField a, FromField a)=> a -> Assertion
+    roundTrip x = do
+      y <- query conn "SELECT ?::json" (Only x)
+      [Only x] @?= y
+
+data DerivingVia1 = DerivingVia1 Int String
+  deriving stock (Eq, Show, Generic)
+  deriving anyclass (FromJSON, ToJSON)
+  deriving (ToField, FromField) via Aeson DerivingVia1
+
+#endif
+
+
 testQM :: TestEnv -> Assertion
 testQM TestEnv{..} = do
     -- Just test on a single string