5bebb26 · typeable/postgresql-simple

git.iko.soy/typeable/postgresql-simple

on master help sign in

Add Newtypes module

5bebb26Oleg Grenrus6 years ago

CHANGES.md+3

compare with master

unifiedsplit

@@ -16,6 +16,9 @@

16 * Fix spurious aborts when retrying transactions

17 Thanks to Elliot Cameron for the implementation

18 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

20### Version 0.6.2 (2019-04-26)

23### Version 0.6.2 (2019-04-26)

postgresql-simple.cabal+1

@@ -48,6 +48,7 @@ library

48 Database.PostgreSQL.Simple.HStore.Internal

49 Database.PostgreSQL.Simple.Internal

50 Database.PostgreSQL.Simple.LargeObjects

51+ Database.PostgreSQL.Simple.Newtypes

51 Database.PostgreSQL.Simple.Notification

52 Database.PostgreSQL.Simple.Notification

52 Database.PostgreSQL.Simple.Ok

53 Database.PostgreSQL.Simple.Ok

53 Database.PostgreSQL.Simple.Range

54 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

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 @@

3{-# LANGUAGE DeriveDataTypeable #-}

4{-# LANGUAGE DoAndIfThenElse #-}

5{-# LANGUAGE ScopedTypeVariables #-}

6+#if __GLASGOW_HASKELL__ >= 806

7+{-# LANGUAGE DerivingStrategies #-}

8+{-# LANGUAGE DerivingVia #-}

9+{-# LANGUAGE DeriveAnyClass #-}

10+#endif

11+module Main (main) where

12+

6import Common

13import Common

7import Database.PostgreSQL.Simple.Copy

14import Database.PostgreSQL.Simple.Copy

15+import Database.PostgreSQL.Simple.ToField (ToField)

8import Database.PostgreSQL.Simple.FromField (FromField)

16import Database.PostgreSQL.Simple.FromField (FromField)

9import Database.PostgreSQL.Simple.HStore

17import Database.PostgreSQL.Simple.HStore

18+import Database.PostgreSQL.Simple.Newtypes

10import Database.PostgreSQL.Simple.Internal (breakOnSingleQuestionMark)

19import Database.PostgreSQL.Simple.Internal (breakOnSingleQuestionMark)

11import Database.PostgreSQL.Simple.Types(Query(..),Values(..), PGArray(..))

20import Database.PostgreSQL.Simple.Types(Query(..),Values(..), PGArray(..))

12import qualified Database.PostgreSQL.Simple.Transaction as ST

21import qualified Database.PostgreSQL.Simple.Transaction as ST

@@ -59,6 +68,8 @@ tests env = testGroup "tests"

59 , testCase "HStore" . testHStore

68 , testCase "HStore" . testHStore

60 , testCase "citext" . testCIText

69 , testCase "citext" . testCIText

61 , testCase "JSON" . testJSON

70 , testCase "JSON" . testJSON

71+ , testCase "Aeson newtype" . testAeson

72+ , testCase "DerivingVia" . testDerivingVia

62 , testCase "Question mark escape" . testQM

73 , testCase "Question mark escape" . testQM

63 , testCase "Savepoint" . testSavepoint

74 , testCase "Savepoint" . testSavepoint

64 , testCase "Unicode" . testUnicode

75 , testCase "Unicode" . testUnicode

@@ -240,6 +251,40 @@ testJSON TestEnv{..} = do

240 js' <- query conn "SELECT ?::json" js

251 js' <- query conn "SELECT ?::json" js

241 [js] @?= js'

252 [js] @?= js'

242

253

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+

243testQM :: TestEnv -> Assertion

288testQM :: TestEnv -> Assertion

244testQM TestEnv{..} = do

289testQM TestEnv{..} = do

245 -- Just test on a single string

290 -- Just test on a single string