Change render format

.github/workflows/ci.yml

@@ -51,7 +51,7 @@ jobs:
       - uses: actions/checkout@v4
       - uses: haskell-actions/run-ormolu@v17
   build:
-    name: GHC ${{ matrix.ghc }} on ${{ matrix.os }}
+    name: GHC ${{ matrix.ghc }} on ${{ matrix.os }} with PostgreSQL ${{ matrix.postgres }}
     needs: meta
     runs-on: ${{ matrix.os }}
     steps:
@@ -63,7 +63,7 @@ jobs:
           cabal: latest
       - run: ghc-pkg list
       - run: cabal sdist --output-dir artifact
-      - run: echo DOCUMENTATION=${{ matrix.ghc == '9.12' && '--enable-documentation --haddock-for-hackage' || '' }} >> $GITHUB_ENV
+      - run: echo DOCUMENTATION=${{ matrix.documentation && '--enable-documentation --haddock-for-hackage' || '' }} >> $GITHUB_ENV
       - run: cabal configure $DOCUMENTATION --enable-tests --flags=pedantic --jobs
       - run: cat cabal.project.local
       - run: cp cabal.project.local artifact
@@ -79,40 +79,78 @@ jobs:
           restore-keys: ${{ matrix.os }}-${{ matrix.ghc }}-
       - run: cabal build --only-download
       - uses: ikalnytskyi/action-setup-postgres@v7
+        with:
+          postgres-version: ${{ matrix.postgres }}
       - run: cabal build --only-dependencies
       - run: cabal build
       - if: ${{ env.DOCUMENTATION }}
         run: cp dist-newstyle/${{ needs.meta.outputs.name }}-${{ needs.meta.outputs.version }}-docs.tar.gz artifact
       - run: tar --create --file artifact.tar --verbose artifact
       - uses: actions/upload-artifact@v4
         with:
-          name: postgresql-simple-interval-${{ github.sha }}-${{ matrix.os }}-${{ matrix.ghc }}
+          name: postgresql-simple-interval-${{ github.sha }}-${{ matrix.os }}-${{ matrix.ghc }}-${{ matrix.postgres }}
           path: artifact.tar
-      - run: cabal run -- postgresql-simple-interval-test-suite --randomize --strict
+      - env:
+          PGPASSWORD: postgres
+        run: cabal run -- postgresql-simple-interval-test-suite --randomize
     strategy:
       matrix:
         include:
-          - ghc: '9.12'
+          - documentation: false
+            ghc: '9.12'
+            postgres: 17
             os: macos-13
-          - ghc: '9.12'
+          - documentation: false
+            ghc: '9.12'
+            postgres: 17
             os: macos-latest
-          - ghc: '8.8'
+          - documentation: false
+            ghc: '8.8'
+            postgres: 17
+            os: ubuntu-latest
+          - documentation: false
+            ghc: '8.10'
+            postgres: 17
+            os: ubuntu-latest
+          - documentation: false
+            ghc: '9.0'
+            postgres: 17
+            os: ubuntu-latest
+          - documentation: false
+            ghc: '9.2'
+            postgres: 17
             os: ubuntu-latest
-          - ghc: '8.10'
+          - documentation: false
+            ghc: '9.4'
+            postgres: 17
             os: ubuntu-latest
-          - ghc: '9.0'
+          - documentation: false
+            ghc: '9.6'
+            postgres: 17
             os: ubuntu-latest
-          - ghc: '9.2'
+          - documentation: false
+            ghc: '9.8'
+            postgres: 17
             os: ubuntu-latest
-          - ghc: '9.4'
+          - documentation: false
+            ghc: '9.10'
+            postgres: 17
             os: ubuntu-latest
-          - ghc: '9.6'
+          - documentation: false
+            ghc: '9.12'
+            postgres: 14
             os: ubuntu-latest
-          - ghc: '9.8'
+          - documentation: false
+            ghc: '9.12'
+            postgres: 15
             os: ubuntu-latest
-          - ghc: '9.10'
+          - documentation: false
+            ghc: '9.12'
+            postgres: 16
             os: ubuntu-latest
-          - ghc: '9.12'
+          - documentation: true
+            ghc: '9.12'
+            postgres: 17
             os: ubuntu-latest
   release:
     if: ${{ github.event_name == 'release' }}
@@ -126,7 +164,7 @@ jobs:
     steps:
       - uses: actions/download-artifact@v4
         with:
-          name: postgresql-simple-interval-${{ github.sha }}-ubuntu-latest-9.12
+          name: postgresql-simple-interval-${{ github.sha }}-ubuntu-latest-9.12-17
       - run: tar --extract --file artifact.tar --verbose
       - uses: softprops/action-gh-release@v2
         with:

postgresql-simple-interval.cabal

@@ -27,6 +27,8 @@ common library
     attoparsec ^>=0.14.4,
     base >=4.13 && <4.22,
     bytestring >=0.10.10 && <0.13,
+    postgresql-simple ^>=0.7,
+    text >=1.2.4 && <1.3 || >=2.0 && <2.2,
 
   default-language: Haskell2010
   ghc-options:
@@ -61,9 +63,7 @@ library
   import: library
   build-depends:
     persistent ^>=2.17,
-    postgresql-simple ^>=0.7,
     scientific ^>=0.3.8,
-    text >=1.2.4 && <1.3 || >=2.0 && <2.2,
 
   -- cabal-gild: discover source/library
   exposed-modules:

source/library/Database/PostgreSQL/Simple/Interval/Unstable.hs

@@ -35,6 +35,12 @@ import qualified Database.PostgreSQL.Simple.TypeInfo.Static as Postgres
 -- - 'Data.Time.CalendarDiffTime': Does not handle days. Embeds a
 --   @NominalDiffTime@. Is not bounded.
 -- - 'Data.Time.CalendarDiffDays': Does not handle seconds. Is not bounded.
+--
+-- WARNING: The PostgreSQL interval parser is broken in versions prior to 15.
+-- It is not possible to round trip all intervals through PostgreSQL on those
+-- versions. You should upgrade to at least PostgreSQL version 15. For more
+-- information, see this patch:
+-- <https://git.postgresql.org/gitweb/?p=postgresql.git;a=commitdiff;h=e39f99046>
 data Interval = MkInterval
   { months :: !Int.Int32,
     days :: !Int.Int32,
@@ -47,7 +53,7 @@ instance Postgres.FromField Interval where
   fromField = Postgres.attoFieldParser (== Postgres.intervalOid) parse
 
 -- | Uses 'render'. Always includes an @interval@ prefix, like
--- @interval '\@ 0 mon -1 day +2 us'@.
+-- @interval '...'@.
 instance Postgres.ToField Interval where
   toField = Postgres.Plain . ("interval '" <>) . (<> "'") . render
 
@@ -204,24 +210,34 @@ add x y =
         <*> Function.on safeAdd microseconds x y
 
 -- | Renders an interval to a 'Builder'. This always has the same format:
--- @"\@ X mon Y day Z us"@, where @X@, @Y@, and @Z@ are signed integers.
+-- @"\@ A mon B day C hour D min E sec F us"@, where @A@, @B@, @C@, @D@, @E@,
+-- and @F@ are signed integers.
 --
 -- This is not the most compact format, but it is very easy to interpret and
 -- does not require dealing with decimals (which could introduce precision
 -- problems).
 --
 -- >>> render MkInterval { months = 0, days = -1, microseconds = 2 }
--- "@ 0 mon -1 day +2 us"
+-- "@ 0 mon -1 day 0 hour 0 min 0 sec +2 us"
 render :: Interval -> Builder.Builder
 render x =
   let signed :: (Num a, Ord a) => (a -> Builder.Builder) -> a -> Builder.Builder
       signed f n = (if n > 0 then "+" else "") <> f n
+      (t1, u) = quotRem (microseconds x) 1000000
+      (t2, s) = quotRem t1 60
+      (h, m) = quotRem t2 60
    in "@ "
         <> signed Builder.int32Dec (months x)
         <> " mon "
         <> signed Builder.int32Dec (days x)
         <> " day "
-        <> signed Builder.int64Dec (microseconds x)
+        <> signed Builder.int64Dec h
+        <> " hour "
+        <> signed Builder.int64Dec m
+        <> " min "
+        <> signed Builder.int64Dec s
+        <> " sec "
+        <> signed Builder.int64Dec u
         <> " us"
 
 -- | Parses an interval. This is not a general purpose parser. It only supports

source/test-suite/Main.hs

@@ -1,14 +1,19 @@
 {-# LANGUAGE NumDecimals #-}
 {-# LANGUAGE OverloadedStrings #-}
 
+import qualified Control.Exception as Exception
 import qualified Control.Monad as Monad
 import qualified Data.Attoparsec.ByteString.Char8 as Attoparsec
 import qualified Data.ByteString as ByteString
 import qualified Data.ByteString.Builder as Builder
 import qualified Data.ByteString.Lazy as LazyByteString
 import qualified Data.Int as Int
+import qualified Data.Text as Text
+import qualified Database.PostgreSQL.Simple as Postgres
 import qualified Database.PostgreSQL.Simple.Interval.Unstable as I
+import qualified Database.PostgreSQL.Simple.ToField as Postgres
 import qualified Test.Hspec as H
+import qualified Text.Read as Read
 
 main :: IO ()
 main = H.hspec spec
@@ -105,15 +110,19 @@ spec = H.describe "Database.PostgreSQL.Simple.Interval" $ do
   H.describe "render" $ do
     H.it "works with zero" $ do
       let actual = Builder.toLazyByteString $ I.render I.zero
-      actual `H.shouldBe` "@ 0 mon 0 day 0 us"
+      actual `H.shouldBe` "@ 0 mon 0 day 0 hour 0 min 0 sec 0 us"
 
     H.it "works with positive components" $ do
       let actual = Builder.toLazyByteString . I.render $ I.MkInterval 1 2 3
-      actual `H.shouldBe` "@ +1 mon +2 day +3 us"
+      actual `H.shouldBe` "@ +1 mon +2 day 0 hour 0 min 0 sec +3 us"
 
     H.it "works with negative components" $ do
       let actual = Builder.toLazyByteString . I.render $ I.MkInterval (-3) (-2) (-1)
-      actual `H.shouldBe` "@ -3 mon -2 day -1 us"
+      actual `H.shouldBe` "@ -3 mon -2 day 0 hour 0 min 0 sec -1 us"
+
+    H.it "works with time components" $ do
+      let actual = Builder.toLazyByteString . I.render $ I.MkInterval 0 0 3723000004
+      actual `H.shouldBe` "@ 0 mon 0 day +1 hour +2 min +3 sec +4 us"
 
   H.describe "parse" $ do
     H.it "fails with invalid input" $ do
@@ -143,13 +152,42 @@ spec = H.describe "Database.PostgreSQL.Simple.Interval" $ do
         let actual = Attoparsec.parseOnly I.parse input
         actual `H.shouldBe` Right interval
 
+  H.describe "integration" $ do
+    Monad.forM_ intervalStyles $ \(style, field) -> do
+      H.describe ("with style " <> show style) $ do
+        Monad.forM_ examples $ \example -> do
+          H.it ("round trips " <> show (field example)) $ do
+            Postgres.withConnect Postgres.defaultConnectInfo $ \connection -> do
+              let interval = exampleInterval example
+              result <- Exception.try . Postgres.withTransaction connection $ do
+                Monad.void $ Postgres.execute connection "set local intervalstyle = ?" [style]
+                Postgres.query connection "select ?" [interval]
+              case result of
+                Right actual -> actual `H.shouldBe` [Postgres.Only interval]
+                Left somePostgresqlException -> do
+                  rows <- Postgres.query_ connection "select version()"
+                  case rows of
+                    Postgres.Only text : _
+                      | _ : rawVersion : _ <- Text.words text,
+                        Just version <- Read.readMaybe (Text.unpack rawVersion),
+                        version < (15 :: Double) ->
+                          H.pendingWith $ "interval parsing broken with PostgreSQL version " <> show version
+                    _ -> Exception.throwIO (somePostgresqlException :: Postgres.SomePostgreSqlException)
+
 data IntervalStyle
   = Iso8601
   | Postgres
   | PostgresVerbose
   | SqlStandard
   deriving (Eq, Show)
 
+instance Postgres.ToField IntervalStyle where
+  toField style = Postgres.Plain $ case style of
+    Iso8601 -> "iso_8601"
+    Postgres -> "postgres"
+    PostgresVerbose -> "postgres_verbose"
+    SqlStandard -> "sql_standard"
+
 data Example = MkExample
   { exampleInterval :: I.Interval,
     exampleIso8601 :: ByteString.ByteString,