From bb6586e3ee6c04c592b1778eb7623549aabbb4a3 Mon Sep 17 00:00:00 2001
From: Ken Micklas <git@kmicklas.com>
Date: Wed, 4 Aug 2021 19:46:42 -0400
Subject: [PATCH] Append `::uuid` to Postgres UUID value syntax

---
 beam-postgres/Database/Beam/Postgres/Syntax.hs    |  9 +++++++--
 .../test/Database/Beam/Postgres/Test/Select.hs    | 15 +++++++++++++++
 2 files changed, 22 insertions(+), 2 deletions(-)

diff --git a/beam-postgres/Database/Beam/Postgres/Syntax.hs b/beam-postgres/Database/Beam/Postgres/Syntax.hs
index 8ed0ce9ea..f61406d1a 100644
--- a/beam-postgres/Database/Beam/Postgres/Syntax.hs
+++ b/beam-postgres/Database/Beam/Postgres/Syntax.hs
@@ -120,7 +120,7 @@ import qualified Data.Text as T
 import qualified Data.Text.Encoding as TE
 import qualified Data.Text.Lazy as TL
 import           Data.Time (LocalTime, UTCTime, TimeOfDay, NominalDiffTime, Day)
-import           Data.UUID.Types (UUID)
+import           Data.UUID.Types (UUID, toASCIIBytes)
 import           Data.Word
 import qualified Data.Vector as V
 import           GHC.TypeLits
@@ -1197,7 +1197,6 @@ DEFAULT_SQL_SYNTAX(UTCTime)
 DEFAULT_SQL_SYNTAX(TimeOfDay)
 DEFAULT_SQL_SYNTAX(NominalDiffTime)
 DEFAULT_SQL_SYNTAX(Day)
-DEFAULT_SQL_SYNTAX(UUID)
 DEFAULT_SQL_SYNTAX([Char])
 DEFAULT_SQL_SYNTAX(Pg.HStoreMap)
 DEFAULT_SQL_SYNTAX(Pg.HStoreList)
@@ -1225,6 +1224,12 @@ instance HasSqlValueSyntax PgValueSyntax B.ByteString where
 instance HasSqlValueSyntax PgValueSyntax BL.ByteString where
   sqlValueSyntax = defaultPgValueSyntax . Pg.Binary
 
+-- This should be removed in favor of the default syntax if/when
+-- https://github.com/lpsmith/postgresql-simple/issues/277 is fixed upstream.
+instance HasSqlValueSyntax PgValueSyntax UUID where
+  sqlValueSyntax v = PgValueSyntax $
+    emit "'" <> emit (toASCIIBytes v) <> emit "'::uuid"
+
 instance Pg.ToField a => HasSqlValueSyntax PgValueSyntax (V.Vector a) where
   sqlValueSyntax = defaultPgValueSyntax
 
diff --git a/beam-postgres/test/Database/Beam/Postgres/Test/Select.hs b/beam-postgres/test/Database/Beam/Postgres/Test/Select.hs
index b483b23e9..4e74dbc7e 100644
--- a/beam-postgres/test/Database/Beam/Postgres/Test/Select.hs
+++ b/beam-postgres/test/Database/Beam/Postgres/Test/Select.hs
@@ -9,6 +9,7 @@ import qualified Data.Vector as V
 import           Test.Tasty
 import           Test.Tasty.HUnit
 import           Data.UUID (UUID, nil)
+import qualified Data.UUID.V5 as V5
 
 import           Database.Beam
 import           Database.Beam.Backend.SQL.SQL92
@@ -39,6 +40,7 @@ tests getConn = testGroup "Selection Tests"
           pgUuidGenerateV4 ext
       , testUuidFunction getConn "uuid_generate_v5" $ \ext ->
           pgUuidGenerateV5 ext (val_ nil) "nil"
+      , testUuuidInValues getConn
       ]
   , testInRowValues getConn
   , testReturningMany getConn
@@ -70,6 +72,19 @@ testUuidFunction getConn name mkUuid = testFunction getConn name $ \conn ->
       return $ mkUuid $ getPgExtension $ _uuidOssp $ unCheckDatabase db
     return ()
 
+-- | Regression test for <https://github.com/haskell-beam/beam/issues/555 #555>
+testUuuidInValues :: IO ByteString -> TestTree
+testUuuidInValues getConn = testCase "UUID in values_ works" $
+  withTestPostgres "uuid_values" getConn $ \conn -> do
+    result <- runBeamPostgres conn $ do
+      db <- executeMigration runNoReturn $ UuidSchema <$>
+        pgCreateExtension @UuidOssp
+      let ext = getPgExtension $ _uuidOssp $ unCheckDatabase db
+      runSelectReturningList $ select $ do
+        v <- values_ [val_ nil]
+        return $ pgUuidGenerateV5 ext v ""
+    assertEqual "result" [V5.generateNamed nil []] result
+
 data Pair f = Pair
   { _left :: C f Bool
   , _right :: C f Bool