git.iko.soy/typeable/postgresql-simple
on master help sign in
Merge pull request #55 from haskellari/newtypes

Add Newtypes module

commitde03aae9f2babee62a2117cea44694de596820a5 authorOleg Grenrus <oleg.grenrus@iki.fi> dateSun 15 Nov 2020, 21:41 (6 years ago) parentcf8a91b5bebb26
4 files changed+98
compare with master
unifiedsplit
CHANGES.md+3 postgresql-simple.cabal+1 src/Database/PostgreSQL/Simple/Newtypes.hs+49 test/Main.hs+45
CHANGES.md+3
@@ -16,6 +16,9 @@
1616 * Fix spurious aborts when retrying transactions
1717 Thanks to Elliot Cameron for the implementation
1818 https://github.com/haskellari/postgresql-simple/pull/34
19+ * Add `Database.PostgreSQL.Simple.Newtypes` module
20+ with `Aeson` newtype.
21+ https://github.com/haskellari/postgresql-simple/pull/55
1922
2023### Version 0.6.2 (2019-04-26)
2124
postgresql-simple.cabal+1
@@ -48,6 +48,7 @@ library
4848 Database.PostgreSQL.Simple.HStore.Internal
4949 Database.PostgreSQL.Simple.Internal
5050 Database.PostgreSQL.Simple.LargeObjects
51+ Database.PostgreSQL.Simple.Newtypes
5152 Database.PostgreSQL.Simple.Notification
5253 Database.PostgreSQL.Simple.Ok
5354 Database.PostgreSQL.Simple.Range
src/Database/PostgreSQL/Simple/Newtypes.hsnew file+49
@@ -0,0 +1,49 @@
1+{-# LANGUAGE DeriveFunctor #-}
2+{-# LANGUAGE DeriveDataTypeable #-}
3+-- | Module with newtypes suitable to usage with @DerivingVia@ or standalone.
4+--
5+-- The newtypes are named after packages they wrap.
6+module Database.PostgreSQL.Simple.Newtypes (
7+ Aeson (..), getAeson,
8+) where
9+
10+import Data.Typeable (Typeable)
11+import Database.PostgreSQL.Simple.ToField (ToField (..))
12+import Database.PostgreSQL.Simple.FromField (FromField (..), fromJSONField)
13+
14+import qualified Data.Aeson as Aeson
15+
16+-------------------------------------------------------------------------------
17+-- aeson
18+-------------------------------------------------------------------------------
19+
20+-- | A newtype wrapper with 'ToField' and 'FromField' instances
21+-- based on 'Aeson.ToJSON' and 'Aeson.FromJSON' type classes from @aeson@.
22+--
23+-- Example using @DerivingVia@:
24+--
25+-- @
26+-- data Foo = Foo Int String
27+-- deriving stock (Eq, Show, Generic) -- GHC built int
28+-- deriving anyclass ('Aeson.FromJSON', 'Aeson.ToJSON') -- Derived using GHC Generics
29+-- deriving ('ToField', 'FromField') via 'Aeson' Foo -- DerivingVia
30+-- @
31+--
32+-- Example using 'Aeson' newtype directly, for more ad-hoc queries
33+--
34+-- @
35+-- execute conn "INSERT INTO tbl (fld) VALUES (?)" (Only ('Aeson' x))
36+-- @
37+--
38+-- @since 0.6.3
39+newtype Aeson a = Aeson a
40+ deriving (Eq, Show, Read, Typeable, Functor)
41+
42+getAeson :: Aeson a -> a
43+getAeson (Aeson a) = a
44+
45+instance Aeson.ToJSON a => ToField (Aeson a) where
46+ toField = toField . Aeson.encode . getAeson
47+
48+instance (Aeson.FromJSON a, Typeable a) => FromField (Aeson a) where
49+ fromField f bs = fmap Aeson (fromJSONField f bs)
test/Main.hs+45
@@ -3,10 +3,19 @@
33{-# LANGUAGE DeriveDataTypeable #-}
44{-# LANGUAGE DoAndIfThenElse #-}
55{-# LANGUAGE ScopedTypeVariables #-}
6+#if __GLASGOW_HASKELL__ >= 806
7+{-# LANGUAGE DerivingStrategies #-}
8+{-# LANGUAGE DerivingVia #-}
9+{-# LANGUAGE DeriveAnyClass #-}
10+#endif
11+module Main (main) where
12+
613import Common
714import Database.PostgreSQL.Simple.Copy
15+import Database.PostgreSQL.Simple.ToField (ToField)
816import Database.PostgreSQL.Simple.FromField (FromField)
917import Database.PostgreSQL.Simple.HStore
18+import Database.PostgreSQL.Simple.Newtypes
1019import Database.PostgreSQL.Simple.Internal (breakOnSingleQuestionMark)
1120import Database.PostgreSQL.Simple.Types(Query(..),Values(..), PGArray(..))
1221import qualified Database.PostgreSQL.Simple.Transaction as ST
@@ -59,6 +68,8 @@ tests env = testGroup "tests"
5968 , testCase "HStore" . testHStore
6069 , testCase "citext" . testCIText
6170 , testCase "JSON" . testJSON
71+ , testCase "Aeson newtype" . testAeson
72+ , testCase "DerivingVia" . testDerivingVia
6273 , testCase "Question mark escape" . testQM
6374 , testCase "Savepoint" . testSavepoint
6475 , testCase "Unicode" . testUnicode
@@ -240,6 +251,40 @@ testJSON TestEnv{..} = do
240251 js' <- query conn "SELECT ?::json" js
241252 [js] @?= js'
242253
254+testAeson :: TestEnv -> Assertion
255+testAeson TestEnv{..} = do
256+ roundTrip (Map.fromList [] :: Map Text Text)
257+ roundTrip (Map.fromList [("foo","bar"),("bar","baz"),("baz","hello")] :: Map Text Text)
258+ roundTrip (Map.fromList [("fo\"o","bar"),("b\\ar","baz"),("baz","\"value\\with\"escapes")] :: Map Text Text)
259+ roundTrip (V.fromList [1,2,3,4,5::Int])
260+ roundTrip ("foo" :: Text)
261+ roundTrip (42 :: Int)
262+ where
263+ roundTrip :: (Eq a, Show a, Typeable a, ToJSON a, FromJSON a)=> a -> Assertion
264+ roundTrip x = do
265+ y <- query conn "SELECT ?::json" (Only (Aeson x))
266+ [Only (Aeson x)] @?= y
267+
268+testDerivingVia :: TestEnv -> Assertion
269+testDerivingVia TestEnv{..} = do
270+#if __GLASGOW_HASKELL__ <806
271+ return ()
272+#else
273+ roundTrip $ DerivingVia1 42 "Meaning of Life"
274+ where
275+ roundTrip :: (Eq a, Show a, Typeable a, ToField a, FromField a)=> a -> Assertion
276+ roundTrip x = do
277+ y <- query conn "SELECT ?::json" (Only x)
278+ [Only x] @?= y
279+
280+data DerivingVia1 = DerivingVia1 Int String
281+ deriving stock (Eq, Show, Generic)
282+ deriving anyclass (FromJSON, ToJSON)
283+ deriving (ToField, FromField) via Aeson DerivingVia1
284+
285+#endif
286+
287+
243288testQM :: TestEnv -> Assertion
244289testQM TestEnv{..} = do
245290 -- Just test on a single string