diff --git a/postgresql-simple-interval.cabal b/postgresql-simple-interval.cabal --- a/postgresql-simple-interval.cabal +++ b/postgresql-simple-interval.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: postgresql-simple-interval -version: 0.2025.7.12 +version: 0.2025.8.27 synopsis: A simple interval type for PostgreSQL. description: This library provides a simple interval type for PostgreSQL. It supports @@ -28,7 +28,6 @@ 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: @@ -64,6 +63,7 @@ build-depends: persistent ^>=2.17, scientific ^>=0.3.8, + text >=1.2.4 && <1.3 || >=2.0 && <2.2, -- cabal-gild: discover source/library exposed-modules: @@ -74,7 +74,10 @@ test-suite postgresql-simple-interval-test-suite import: executable - build-depends: hspec ^>=2.11.12 + build-depends: + hspec ^>=2.11.12, + postgresql-libpq ^>=0.11, + hs-source-dirs: source/test-suite main-is: Main.hs type: exitcode-stdio-1.0 diff --git a/source/library/Database/PostgreSQL/Simple/Interval.hs b/source/library/Database/PostgreSQL/Simple/Interval.hs --- a/source/library/Database/PostgreSQL/Simple/Interval.hs +++ b/source/library/Database/PostgreSQL/Simple/Interval.hs @@ -1,5 +1,7 @@ module Database.PostgreSQL.Simple.Interval ( Unstable.Interval (..), + + -- * Constructors Unstable.zero, Unstable.fromMicroseconds, Unstable.fromMilliseconds, @@ -10,6 +12,28 @@ Unstable.fromWeeks, Unstable.fromMonths, Unstable.fromYears, + + -- ** Saturating + Unstable.fromMillisecondsSaturating, + Unstable.fromSecondsSaturating, + Unstable.fromMinutesSaturating, + Unstable.fromHoursSaturating, + Unstable.fromWeeksSaturating, + Unstable.fromYearsSaturating, + + -- ** Literal + Unstable.fromMillisecondsLiteral, + Unstable.fromSecondsLiteral, + Unstable.fromMinutesLiteral, + Unstable.fromHoursLiteral, + Unstable.fromWeeksLiteral, + Unstable.fromYearsLiteral, + + -- * Arithmetic + Unstable.negate, + Unstable.negateSaturating, + Unstable.add, + Unstable.addSaturating, ) where diff --git a/source/library/Database/PostgreSQL/Simple/Interval/Unstable.hs b/source/library/Database/PostgreSQL/Simple/Interval/Unstable.hs --- a/source/library/Database/PostgreSQL/Simple/Interval/Unstable.hs +++ b/source/library/Database/PostgreSQL/Simple/Interval/Unstable.hs @@ -1,5 +1,9 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE NumDecimals #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-redundant-constraints #-} module Database.PostgreSQL.Simple.Interval.Unstable where @@ -20,6 +24,7 @@ import qualified Database.PostgreSQL.Simple.FromField as Postgres import qualified Database.PostgreSQL.Simple.ToField as Postgres import qualified Database.PostgreSQL.Simple.TypeInfo.Static as Postgres +import qualified GHC.TypeLits as TypeLits -- | This type represents a PostgreSQL interval. Intervals can have month, day, -- and microsecond components. Each component is bounded, so they are not @@ -110,6 +115,34 @@ . (* 1e3) . toInteger +-- | Like 'fromMilliseconds' but uses saturating arithmetic rather than +-- returning 'Maybe'. +-- +-- >>> fromMillisecondsSaturating 1 +-- MkInterval {months = 0, days = 0, microseconds = 1000} +-- >>> fromMillisecondsSaturating 9223372036854776 +-- MkInterval {months = 0, days = 0, microseconds = 9223372036854775807} +fromMillisecondsSaturating :: Int.Int64 -> Interval +fromMillisecondsSaturating = + fromMicroseconds + . toIntegralSaturating + . (* 1e3) + . toInteger + +-- | Like 'fromMilliseconds' but takes a type-level natural number as input. +-- This is useful for writing literals without risk of overflow. +-- +-- >>> fromMillisecondsLiteral (Proxy :: Proxy 1) +-- MkInterval {months = 0, days = 0, microseconds = 1000} +fromMillisecondsLiteral :: + (TypeLits.KnownNat n, (TypeLits.<=) n 9223372036854775) => + proxy n -> + Interval +fromMillisecondsLiteral = + fromMillisecondsSaturating + . fromInteger + . TypeLits.natVal + -- | Creates an interval from a number of seconds. Returns 'Nothing' if the -- interval would overflow. -- @@ -124,6 +157,34 @@ . (* 1e6) . toInteger +-- | Like 'fromSeconds' but uses saturating arithmetic rather than returning +-- 'Maybe'. +-- +-- >>> fromSecondsSaturating 1 +-- MkInterval {months = 0, days = 0, microseconds = 1000000} +-- >>> fromSecondsSaturating 9223372036855 +-- MkInterval {months = 0, days = 0, microseconds = 9223372036854775807} +fromSecondsSaturating :: Int.Int64 -> Interval +fromSecondsSaturating = + fromMicroseconds + . toIntegralSaturating + . (* 1e6) + . toInteger + +-- | Like 'fromSeconds' but takes a type-level natural number as input. +-- This is useful for writing literals without risk of overflow. +-- +-- >>> fromSecondsLiteral (Proxy :: Proxy 1) +-- MkInterval {months = 0, days = 0, microseconds = 1000000} +fromSecondsLiteral :: + (TypeLits.KnownNat n, (TypeLits.<=) n 9223372036854) => + proxy n -> + Interval +fromSecondsLiteral = + fromSecondsSaturating + . fromInteger + . TypeLits.natVal + -- | Creates an interval from a number of minutes. Returns 'Nothing' if the -- interval would overflow. -- @@ -138,6 +199,34 @@ . (* 60e6) . toInteger +-- | Like 'fromMinutes' but uses saturating arithmetic rather than returning +-- 'Maybe'. +-- +-- >>> fromMinutesSaturating 1 +-- MkInterval {months = 0, days = 0, microseconds = 60000000} +-- >>> fromMinutesSaturating 153722867281 +-- MkInterval {months = 0, days = 0, microseconds = 9223372036854775807} +fromMinutesSaturating :: Int.Int64 -> Interval +fromMinutesSaturating = + fromMicroseconds + . toIntegralSaturating + . (* 60e6) + . toInteger + +-- | Like 'fromMinutes' but takes a type-level natural number as input. +-- This is useful for writing literals without risk of overflow. +-- +-- >>> fromMinutesLiteral (Proxy :: Proxy 1) +-- MkInterval {months = 0, days = 0, microseconds = 60000000} +fromMinutesLiteral :: + (TypeLits.KnownNat n, (TypeLits.<=) n 153722867280) => + proxy n -> + Interval +fromMinutesLiteral = + fromMinutesSaturating + . fromInteger + . TypeLits.natVal + -- | Creates an interval from a number of hours. Returns 'Nothing' if the -- interval would overflow. -- @@ -152,6 +241,34 @@ . (* 3600e6) . toInteger +-- | Like 'fromHours' but uses saturating arithmetic rather than returning +-- 'Maybe'. +-- +-- >>> fromHoursSaturating 1 +-- MkInterval {months = 0, days = 0, microseconds = 3600000000} +-- >>> fromHoursSaturating 2562047789 +-- MkInterval {months = 0, days = 0, microseconds = 9223372036854775807} +fromHoursSaturating :: Int.Int64 -> Interval +fromHoursSaturating = + fromMicroseconds + . toIntegralSaturating + . (* 3600e6) + . toInteger + +-- | Like 'fromHours' but takes a type-level natural number as input. +-- This is useful for writing literals without risk of overflow. +-- +-- >>> fromHoursLiteral (Proxy :: Proxy 1) +-- MkInterval {months = 0, days = 0, microseconds = 3600000000} +fromHoursLiteral :: + (TypeLits.KnownNat n, (TypeLits.<=) n 2562047788) => + proxy n -> + Interval +fromHoursLiteral = + fromHoursSaturating + . fromInteger + . TypeLits.natVal + -- | Creates an interval from a number of days. -- -- >>> fromDays 1 @@ -173,6 +290,34 @@ . (* 7) . toInteger +-- | Like 'fromWeeks' but uses saturating arithmetic rather than returning +-- 'Maybe'. +-- +-- >>> fromWeeksSaturating 1 +-- MkInterval {months = 0, days = 7, microseconds = 0} +-- >>> fromWeeksSaturating 306783379 +-- MkInterval {months = 0, days = 2147483647, microseconds = 0} +fromWeeksSaturating :: Int.Int32 -> Interval +fromWeeksSaturating = + fromDays + . toIntegralSaturating + . (* 7) + . toInteger + +-- | Like 'fromWeeks' but takes a type-level natural number as input. +-- This is useful for writing literals without risk of overflow. +-- +-- >>> fromWeeksLiteral (Proxy :: Proxy 1) +-- MkInterval {months = 0, days = 7, microseconds = 0} +fromWeeksLiteral :: + (TypeLits.KnownNat n, (TypeLits.<=) n 306783378) => + proxy n -> + Interval +fromWeeksLiteral = + fromWeeksSaturating + . fromInteger + . TypeLits.natVal + -- | Creates an interval from a number of months. -- -- >>> fromMonths 1 @@ -194,6 +339,65 @@ . (* 12) . toInteger +-- | Like 'fromYears' but uses saturating arithmetic rather than returning +-- 'Maybe'. +-- +-- >>> fromYearsSaturating 1 +-- MkInterval {months = 12, days = 0, microseconds = 0} +-- >>> fromYearsSaturating 178956971 +-- MkInterval {months = 2147483647, days = 0, microseconds = 0} +fromYearsSaturating :: Int.Int32 -> Interval +fromYearsSaturating = + fromMonths + . toIntegralSaturating + . (* 12) + . toInteger + +-- | Like 'fromYears' but takes a type-level natural number as input. +-- This is useful for writing literals without risk of overflow. +-- +-- >>> fromYearsLiteral (Proxy :: Proxy 1) +-- MkInterval {months = 12, days = 0, microseconds = 0} +fromYearsLiteral :: + (TypeLits.KnownNat n, (TypeLits.<=) n 178956970) => + proxy n -> + Interval +fromYearsLiteral = + fromYearsSaturating + . fromInteger + . TypeLits.natVal + +-- | Negates an interval. Returns 'Nothing' if the result would overflow. +-- +-- >>> negate (MkInterval 1 2 3) +-- Just (MkInterval {months = -1, days = -2, microseconds = -3}) +-- >>> negate (MkInterval (-2147483648) 0 0) +-- Nothing +negate :: Interval -> Maybe Interval +negate x = + let safeNegate :: (Bits.Bits a, Integral a) => a -> Maybe a + safeNegate = Bits.toIntegralSized . Prelude.negate . toInteger + in MkInterval + <$> safeNegate (months x) + <*> safeNegate (days x) + <*> safeNegate (microseconds x) + +-- | Like 'Database.PostgreSQL.Simple.Interval.Unstable.negate' but uses +-- saturating arithmetic rather than returning 'Maybe'. +-- +-- >>> negateSaturating (MkInterval 1 2 3) +-- MkInterval {months = -1, days = -2, microseconds = -3} +-- >>> negateSaturating (MkInterval (-2147483648) 0 0) +-- MkInterval {months = 2147483647, days = 0, microseconds = 0} +negateSaturating :: Interval -> Interval +negateSaturating x = + let safeNegate :: (Bounded a, Integral a) => a -> a + safeNegate = toIntegralSaturating . Prelude.negate . toInteger + in MkInterval + (safeNegate $ months x) + (safeNegate $ days x) + (safeNegate $ microseconds x) + -- | Adds two intervals. Returns 'Nothing' if the result would overflow. -- -- >>> add (fromMonths 1) (fromDays 2) @@ -209,6 +413,21 @@ <*> Function.on safeAdd days x y <*> Function.on safeAdd microseconds x y +-- | Like 'add' but uses saturating arithmetic rather than returning 'Maybe'. +-- +-- >>> addSaturating (fromMonths 1) (fromDays 2) +-- MkInterval {months = 1, days = 2, microseconds = 0} +-- >>> addSaturating (fromDays 2147483647) (fromDays 1) +-- MkInterval {months = 0, days = 2147483647, microseconds = 0} +addSaturating :: Interval -> Interval -> Interval +addSaturating x y = + let safeAdd :: (Bounded a, Integral a) => a -> a -> a + safeAdd n = toIntegralSaturating . Function.on (+) toInteger n + in MkInterval + (Function.on safeAdd months x y) + (Function.on safeAdd days x y) + (Function.on safeAdd microseconds x y) + -- | Renders an interval to a 'Builder'. This always has the same format: -- @"\@ A mon B day C hour D min E sec F us"@, where @A@, @B@, @C@, @D@, @E@, -- and @F@ are signed integers. @@ -391,3 +610,10 @@ negateComponentsWhen :: (Functor f) => Bool -> f Component -> f Component negateComponentsWhen p = if p then fmap negateComponent else id + +toIntegralSaturating :: forall a b. (Integral a, Integral b, Bounded b) => a -> b +toIntegralSaturating x = case toInteger x of + y + | let lo = minBound :: b, y < toInteger lo -> lo + | let hi = maxBound :: b, y > toInteger hi -> hi + | otherwise -> fromInteger y diff --git a/source/test-suite/Main.hs b/source/test-suite/Main.hs --- a/source/test-suite/Main.hs +++ b/source/test-suite/Main.hs @@ -1,5 +1,7 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE NumDecimals #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} import qualified Control.Exception as Exception import qualified Control.Monad as Monad @@ -8,12 +10,13 @@ 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 Data.Proxy as Proxy +import qualified Database.PostgreSQL.LibPQ as Pq import qualified Database.PostgreSQL.Simple as Postgres +import qualified Database.PostgreSQL.Simple.Internal 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 @@ -53,6 +56,35 @@ let actual = I.add (I.fromMicroseconds minBound) (I.fromMicroseconds (-1)) actual `H.shouldBe` Nothing + H.describe "addSaturating" $ do + H.it "succeeds without saturating" $ do + let actual = I.addSaturating (I.MkInterval 1 2 3) (I.MkInterval 4 5 6) + actual `H.shouldBe` I.MkInterval 5 7 9 + + H.it "succeeds with saturating positive month" $ do + let actual = I.addSaturating (I.fromMonths maxBound) (I.fromMonths 1) + actual `H.shouldBe` I.MkInterval maxBound 0 0 + + H.it "succeeds with saturating negative month" $ do + let actual = I.addSaturating (I.fromMonths minBound) (I.fromMonths (-1)) + actual `H.shouldBe` I.MkInterval minBound 0 0 + + H.it "succeeds with saturating positive day" $ do + let actual = I.addSaturating (I.fromDays maxBound) (I.fromDays 1) + actual `H.shouldBe` I.MkInterval 0 maxBound 0 + + H.it "succeeds with saturating negative day" $ do + let actual = I.addSaturating (I.fromDays minBound) (I.fromDays (-1)) + actual `H.shouldBe` I.MkInterval 0 minBound 0 + + H.it "succeeds with saturating positive microsecond" $ do + let actual = I.addSaturating (I.fromMicroseconds maxBound) (I.fromMicroseconds 1) + actual `H.shouldBe` I.MkInterval 0 0 maxBound + + H.it "succeeds with saturating negative microsecond" $ do + let actual = I.addSaturating (I.fromMicroseconds minBound) (I.fromMicroseconds (-1)) + actual `H.shouldBe` I.MkInterval 0 0 minBound + H.describe "fromMicroseconds" $ do H.it "works" $ do I.fromMicroseconds 1 `H.shouldBe` I.MkInterval 0 0 1 @@ -64,6 +96,17 @@ H.it "fails with overflow" $ do I.fromMilliseconds maxBound `H.shouldBe` Nothing + H.describe "fromMillisecondsSaturating" $ do + H.it "succeeds without saturating" $ do + I.fromMillisecondsSaturating 1 `H.shouldBe` I.MkInterval 0 0 1e3 + + H.it "succeeds with saturating" $ do + I.fromMillisecondsSaturating maxBound `H.shouldBe` I.MkInterval 0 0 9223372036854775807 + + H.describe "fromMillisecondsLiteral" $ do + H.it "succeeds" $ do + I.fromMillisecondsLiteral @1 Proxy.Proxy `H.shouldBe` I.MkInterval 0 0 1e3 + H.describe "fromSeconds" $ do H.it "succeeds with no overflow" $ do I.fromSeconds 1 `H.shouldBe` Just (I.MkInterval 0 0 1e6) @@ -71,6 +114,17 @@ H.it "fails with overflow" $ do I.fromSeconds maxBound `H.shouldBe` Nothing + H.describe "fromSecondsSaturating" $ do + H.it "succeeds without saturating" $ do + I.fromSecondsSaturating 1 `H.shouldBe` I.MkInterval 0 0 1e6 + + H.it "succeeds with saturating" $ do + I.fromSecondsSaturating maxBound `H.shouldBe` I.MkInterval 0 0 9223372036854775807 + + H.describe "fromSecondsLiteral" $ do + H.it "succeeds" $ do + I.fromSecondsLiteral @1 Proxy.Proxy `H.shouldBe` I.MkInterval 0 0 1e6 + H.describe "fromMinutes" $ do H.it "succeeds with no overflow" $ do I.fromMinutes 1 `H.shouldBe` Just (I.MkInterval 0 0 60e6) @@ -78,6 +132,17 @@ H.it "fails with overflow" $ do I.fromMinutes maxBound `H.shouldBe` Nothing + H.describe "fromMinutesSaturating" $ do + H.it "succeeds without saturating" $ do + I.fromMinutesSaturating 1 `H.shouldBe` I.MkInterval 0 0 60e6 + + H.it "succeeds with saturating" $ do + I.fromMinutesSaturating maxBound `H.shouldBe` I.MkInterval 0 0 9223372036854775807 + + H.describe "fromMinutesLiteral" $ do + H.it "succeeds" $ do + I.fromMinutesLiteral @1 Proxy.Proxy `H.shouldBe` I.MkInterval 0 0 60e6 + H.describe "fromHours" $ do H.it "succeeds with no overflow" $ do I.fromHours 1 `H.shouldBe` Just (I.MkInterval 0 0 3600e6) @@ -85,6 +150,17 @@ H.it "fails with overflow" $ do I.fromHours maxBound `H.shouldBe` Nothing + H.describe "fromHoursSaturating" $ do + H.it "succeeds without saturating" $ do + I.fromHoursSaturating 1 `H.shouldBe` I.MkInterval 0 0 3600e6 + + H.it "succeeds with saturating" $ do + I.fromHoursSaturating maxBound `H.shouldBe` I.MkInterval 0 0 9223372036854775807 + + H.describe "fromHoursLiteral" $ do + H.it "succeeds" $ do + I.fromHoursLiteral @1 Proxy.Proxy `H.shouldBe` I.MkInterval 0 0 3600e6 + H.describe "fromDays" $ do H.it "works" $ do I.fromDays 1 `H.shouldBe` I.MkInterval 0 1 0 @@ -96,6 +172,17 @@ H.it "fails with overflow" $ do I.fromWeeks maxBound `H.shouldBe` Nothing + H.describe "fromWeeksSaturating" $ do + H.it "succeeds without saturating" $ do + I.fromWeeksSaturating 1 `H.shouldBe` I.MkInterval 0 7 0 + + H.it "succeeds with saturating" $ do + I.fromWeeksSaturating maxBound `H.shouldBe` I.MkInterval 0 2147483647 0 + + H.describe "fromWeeksLiteral" $ do + H.it "succeeds" $ do + I.fromWeeksLiteral @1 Proxy.Proxy `H.shouldBe` I.MkInterval 0 7 0 + H.describe "fromMonths" $ do H.it "works" $ do I.fromMonths 1 `H.shouldBe` I.MkInterval 1 0 0 @@ -107,6 +194,43 @@ H.it "fails with overflow" $ do I.fromYears maxBound `H.shouldBe` Nothing + H.describe "fromYearsSaturating" $ do + H.it "succeeds without saturating" $ do + I.fromYearsSaturating 1 `H.shouldBe` I.MkInterval 12 0 0 + + H.it "succeeds with saturating" $ do + I.fromYearsSaturating maxBound `H.shouldBe` I.MkInterval 2147483647 0 0 + + H.describe "fromYearsLiteral" $ do + H.it "succeeds" $ do + I.fromYearsLiteral @1 Proxy.Proxy `H.shouldBe` I.MkInterval 12 0 0 + + H.describe "negate" $ do + H.it "succeeds with no overflow" $ do + I.negate (I.MkInterval 1 2 3) `H.shouldBe` Just (I.MkInterval (-1) (-2) (-3)) + + H.it "fails with month overflow" $ do + I.negate (I.MkInterval minBound 0 0) `H.shouldBe` Nothing + + H.it "fails with day overflow" $ do + I.negate (I.MkInterval 0 minBound 0) `H.shouldBe` Nothing + + H.it "fails with microsecond overflow" $ do + I.negate (I.MkInterval 0 0 minBound) `H.shouldBe` Nothing + + H.describe "negateSaturating" $ do + H.it "succeeds without saturating" $ do + I.negateSaturating (I.MkInterval 1 2 3) `H.shouldBe` I.MkInterval (-1) (-2) (-3) + + H.it "succeeds with saturating month" $ do + I.negateSaturating (I.MkInterval minBound 0 0) `H.shouldBe` I.MkInterval maxBound 0 0 + + H.it "succeeds with saturating day" $ do + I.negateSaturating (I.MkInterval 0 minBound 0) `H.shouldBe` I.MkInterval 0 maxBound 0 + + H.it "succeeds with saturating microsecond" $ do + I.negateSaturating (I.MkInterval 0 0 minBound) `H.shouldBe` I.MkInterval 0 0 maxBound + H.describe "render" $ do H.it "works with zero" $ do let actual = Builder.toLazyByteString $ I.render I.zero @@ -165,14 +289,10 @@ 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) + version <- Postgres.withConnection connection Pq.serverVersion + if version < 150000 + then H.pendingWith $ "interval parsing broken with PostgreSQL version " <> show version + else Exception.throwIO (somePostgresqlException :: Postgres.SomePostgreSqlException) data IntervalStyle = Iso8601