Add interval Type

postgresql-simple.cabal

@@ -54,6 +54,7 @@ Library
      Database.PostgreSQL.Simple.Time.Implementation
      Database.PostgreSQL.Simple.Time.Internal.Parser
      Database.PostgreSQL.Simple.Time.Internal.Printer
+     Database.PostgreSQL.Simple.Time.Interval
      Database.PostgreSQL.Simple.TypeInfo.Types
 
   Build-depends:

src/Database/PostgreSQL/Simple/FromField.hs

@@ -475,6 +475,10 @@ instance FromField LocalTimestamp where
 instance FromField Date where
   fromField = ff $(inlineTypoid TI.date) "Date" parseDate
 
+-- | interval
+instance FromField Interval where
+  fromField = ff $(inlineTypoid TI.interval) "Interval" parseInterval
+
 ff :: PQ.Oid -> String -> (B8.ByteString -> Either String a)
    -> Field -> Maybe B8.ByteString -> Conversion a
 ff compatOid hsType parse f mstr =

src/Database/PostgreSQL/Simple/Time.hs

@@ -218,6 +218,8 @@ module Database.PostgreSQL.Simple.Time
      , UTCTimestamp
      , ZonedTimestamp
      , LocalTimestamp
+     , Interval(..)
+     , zeroInterval
      , parseDay
      , parseUTCTime
      , parseZonedTime
@@ -227,6 +229,7 @@ module Database.PostgreSQL.Simple.Time
      , parseUTCTimestamp
      , parseZonedTimestamp
      , parseLocalTimestamp
+     , parseInterval
      , dayToBuilder
      , utcTimeToBuilder
      , zonedTimeToBuilder
@@ -239,6 +242,8 @@ module Database.PostgreSQL.Simple.Time
      , localTimestampToBuilder
      , unboundedToBuilder
      , nominalDiffTimeToBuilder
+     , intervalBuilder
      ) where
 
 import Database.PostgreSQL.Simple.Time.Implementation
+import Database.PostgreSQL.Simple.Time.Interval

src/Database/PostgreSQL/Simple/Time/Implementation.hs

@@ -23,6 +23,7 @@ import Data.Typeable
 import Data.Maybe (fromMaybe)
 import qualified Data.Attoparsec.ByteString.Char8 as A
 import Database.PostgreSQL.Simple.Compat ((<>))
+import Database.PostgreSQL.Simple.Time.Interval (Interval)
 import qualified Database.PostgreSQL.Simple.Time.Internal.Parser  as TP
 import qualified Database.PostgreSQL.Simple.Time.Internal.Printer as TPP
 
@@ -50,6 +51,9 @@ type UTCTimestamp   = Unbounded UTCTime
 type ZonedTimestamp = Unbounded ZonedTime
 type Date           = Unbounded Day
 
+parseInterval :: B.ByteString -> Either String Interval
+parseInterval = A.parseOnly TP.interval
+
 parseUTCTime   :: B.ByteString -> Either String UTCTime
 parseUTCTime   = A.parseOnly (getUTCTime <* A.endOfInput)
 
@@ -164,3 +168,6 @@ dateToBuilder  = unboundedToBuilder dayToBuilder
 
 nominalDiffTimeToBuilder :: NominalDiffTime -> Builder
 nominalDiffTimeToBuilder = TPP.nominalDiffTime
+
+intervalBuilder :: Interval -> Builder
+intervalBuilder = TPP.interval

src/Database/PostgreSQL/Simple/Time/Internal/Parser.hs

@@ -21,10 +21,13 @@ module Database.PostgreSQL.Simple.Time.Internal.Parser
     , localToUTCTimeOfDayHMS
     , utcTime
     , zonedTime
+    , interval
     ) where
 
+import Prelude as P
 import Control.Applicative ((<$>), (<*>), (<*), (*>))
 import Database.PostgreSQL.Simple.Compat (toPico)
+import Database.PostgreSQL.Simple.Time.Interval (Interval(..))
 import Data.Attoparsec.ByteString.Char8 as A
 import Data.Bits ((.&.))
 import Data.Char (ord)
@@ -193,3 +196,44 @@ zonedTime = Local.ZonedTime <$> localTime <*> (fromMaybe utc <$> timeZone)
 
 utc :: Local.TimeZone
 utc = Local.TimeZone 0 False ""
+
+
+-- | Parse an interval of the form @[A year[s][ ][B mon[s][ ]][C day[s][ ]][[-]XXX:YY:ZZ[.[Z[Z[Z[Z]]]]]]@.
+-- (PosgreSQL default interval output format.)
+interval :: Parser Interval
+interval = do
+  parsedYears <- option 0 $ signed decimal <* string " year" <* optionalS <* optionalSpace
+  parsedMonths <- option 0 $ signed decimal <* string " mon" <* optionalS <* optionalSpace
+  parsedDays <- option 0 $ signed decimal <* string " day" <* optionalS <* optionalSpace
+  parsedMicroseconds <- option 0 $ do
+    possibleNegativeSign <- peekChar'
+    normalizeSign <- case possibleNegativeSign of '-' -> anyChar *> return negate
+                                                  _   -> return id
+    parsedHours <- decimal <* char ':'
+    parsedMinutes <- twoDigits <* char ':'
+    microsecondsOfSeconds <- (*microsecondScale) <$> twoDigits
+    maybePartialSeconds <- option Nothing $ Just <$> do
+      partialSecondStr <- char '.' *> many1 digit
+      let partialSeconds = read $ P.take 6 $ partialSecondStr ++ repeat '0'
+      return partialSeconds
+
+    let minutesMicros = microsecondScale * 60 * fromIntegral parsedMinutes
+    let hoursMicros = microsecondScale * 3600 * parsedHours
+    let parsedMicroseconds = case maybePartialSeconds of Nothing ->
+                                                          microsecondsOfSeconds +
+                                                          minutesMicros +
+                                                          hoursMicros
+                                                         Just parsedPartialSecond ->
+                                                          microsecondsOfSeconds + parsedPartialSecond +
+                                                          minutesMicros +
+                                                          hoursMicros
+
+    return $ normalizeSign parsedMicroseconds
+
+  let allMonths = 12 * parsedYears + parsedMonths
+  return Interval { intervalMonths = allMonths,
+                    intervalDays = parsedDays,
+                    intervalMicroseconds = fromIntegral parsedMicroseconds}
+    where optionalS = option 's' (char 's')
+          optionalSpace = option ' ' space
+          microsecondScale = 1000000

src/Database/PostgreSQL/Simple/Time/Internal/Printer.hs

@@ -17,20 +17,22 @@ module Database.PostgreSQL.Simple.Time.Internal.Printer
     , localTime
     , zonedTime
     , nominalDiffTime
+    , interval
     ) where
 
 import Control.Arrow ((>>>))
 import Data.ByteString.Builder (Builder, integerDec)
 import Data.ByteString.Builder.Prim
     ( liftFixedToBounded, (>$<), (>*<)
-    , BoundedPrim, primBounded, condB, emptyB, FixedPrim, char8, int32Dec)
+    , BoundedPrim, primBounded, condB, emptyB, FixedPrim, char8, int32Dec, int64Dec, primFixed)
 import Data.Char ( chr )
 import Data.Int ( Int32, Int64 )
 import Data.Time
     ( UTCTime(..), ZonedTime(..), LocalTime(..), NominalDiffTime
     , Day, toGregorian, TimeOfDay(..), timeToTimeOfDay
     , TimeZone, timeZoneMinutes )
 import Database.PostgreSQL.Simple.Compat ((<>), fromPico)
+import Database.PostgreSQL.Simple.Time.Interval (Interval(..))
 import Unsafe.Coerce (unsafeCoerce)
 
 liftB :: FixedPrim a -> BoundedPrim a
@@ -121,3 +123,37 @@ nominalDiffTime :: NominalDiffTime -> Builder
 nominalDiffTime xy = integerDec x <> primBounded frac (abs (fromIntegral y))
   where
     (x,y) = fromPico (unsafeCoerce xy) `quotRem` 1000000000000
+
+
+interval :: Interval -> Builder
+interval x = boundedPrefix <> integerDec afterSeconds <> fixedSuffix
+  where
+    (hours, afterHours) = intervalMicroseconds x `quotRem` 3600000000
+    (minutes, afterMinutes) = afterHours `quotRem` 60000000
+    (seconds, afterSeconds) = afterMinutes `quotRem` 1000000
+
+    boundedPrefix = primBounded
+      (int32Dec >*<
+        liftB char8 >*< liftB char8 >*< liftB char8 >*< liftB char8 >*< liftB char8 >*< liftB char8 >*<
+        int32Dec >*<
+        liftB char8 >*< liftB char8 >*< liftB char8 >*< liftB char8 >*< liftB char8 >*< liftB char8 >*<
+        int64Dec >*<
+        liftB char8 >*< liftB char8 >*< liftB char8 >*< liftB char8 >*< liftB char8 >*< liftB char8 >*< liftB char8 >*<
+        int64Dec >*<
+        liftB char8 >*< liftB char8 >*< liftB char8 >*< liftB char8 >*< liftB char8 >*< liftB char8 >*<
+        int64Dec >*<
+        liftB char8 >*< liftB char8 >*< liftB char8 >*< liftB char8 >*< liftB char8 >*< liftB char8)
+      (intervalMonths x,
+        (' ', ('m', ('o', ('n', ('s', (' ',
+        (intervalDays x,
+        (' ', ('d', ('a', ('y', ('s', (' ',
+        (fromIntegral hours,
+        (' ', ('h', ('o', ('u', ('r', ('s', (' ',
+        (fromIntegral minutes,
+        (' ', ('m', ('i', ('n', ('s', (' ',
+        (fromIntegral seconds,
+        (' ', ('s', ('e', ('c', ('s', ' ')))))))))))))))))))))))))))))))))))
+
+    fixedSuffix = primFixed (char8 >*< char8 >*< char8 >*< char8 >*< char8 >*< char8 >*< char8 >*< char8 >*<
+                             char8 >*< char8 >*< char8 >*< char8 >*< char8)
+                            (' ', ('m', ('i', ('c', ('r', ('o', ('s', ('e', ('c', ('o', ('n', ('d', 's'))))))))))))

src/Database/PostgreSQL/Simple/Time/Interval.hs

@@ -0,0 +1,11 @@
+module Database.PostgreSQL.Simple.Time.Interval where
+
+import Data.Int
+
+data Interval = Interval { intervalMonths :: Int32
+                         , intervalDays :: Int32
+                         , intervalMicroseconds :: Integer }
+                         deriving (Show, Read, Eq)
+
+zeroInterval :: Interval
+zeroInterval = Interval 0 0 0

src/Database/PostgreSQL/Simple/ToField.hs

@@ -271,6 +271,10 @@ instance ToField NominalDiffTime where
     toField = Plain . inQuotes . nominalDiffTimeToBuilder
     {-# INLINE toField #-}
 
+instance ToField Interval where
+    toField = Plain . inQuotes . intervalBuilder
+    {-# INLINE toField #-}
+
 instance (ToField a) => ToField (PGArray a) where
     toField pgArray =
       case fromPGArray pgArray of

test/Main.hs

@@ -47,6 +47,7 @@ tests env = testGroup "tests"
     , testCase "Notify"             . testNotify
     , testCase "Serializable"       . testSerializable
     , testCase "Time"               . testTime
+    , testCase "Interval"           . testInterval
     , testCase "Array"              . testArray
     , testCase "Array of nullables" . testNullableArray
     , testCase "HStore"             . testHStore

test/Time.hs

@@ -32,13 +32,14 @@ generated with granularity of seconds down to microseconds in powers of ten.
 
 -}
 
-module Time (testTime) where
+module Time (testTime, testInterval) where
 
 import Common
 import Control.Monad(forM_, replicateM_)
 import Data.Time
 import Data.ByteString(ByteString)
 import Database.PostgreSQL.Simple.SqlQQ
+import Database.PostgreSQL.Simple.Time
 
 numTests :: Int
 numTests = 200
@@ -117,3 +118,38 @@ checkRoundTrips TestEnv{..} limit = do
       res <- query conn [sql| SELECT y=? FROM testtime WHERE x=? |] yx
       assertBool "ZonedTime did not round-trip from SQL to Haskell and back" $
                  res == [Only True]
+
+testInterval :: TestEnv -> Assertion
+testInterval env@TestEnv{..} = do
+  initializeIntervalTable env
+  checkIntervalRoundTrips env
+
+initializeIntervalTable :: TestEnv -> IO ()
+initializeIntervalTable TestEnv{..} = withTransaction conn $ do
+  execute_ conn [sql| CREATE TEMPORARY TABLE test_interval
+                         ( x serial, y interval, PRIMARY KEY(x) )|]
+  let test :: ByteString -> IO () = \x -> do
+                 execute conn [sql|
+                     INSERT INTO test_interval (y) VALUES (?::interval)
+                  |] (Only x)
+                 return ()
+  test "10 mon"
+  test "1 mons"
+  test "10 day"
+  test "1 days"
+  test "10 year"
+  test "1 years"
+  test "00:00:00.000001"
+  test "100000:00:00"
+  test "-04:00:00"
+  test "10 years 10 mons 10 days 1000:10:10.101101"
+  test "-15 years -15 mons -10 days -1515:15:15.151515"
+  test "20 years -8 months 11111 days -00:00:01.1"
+
+checkIntervalRoundTrips :: TestEnv -> IO ()
+checkIntervalRoundTrips TestEnv{..} = do
+  yxs :: [(Interval, Int)] <- query_ conn [sql| SELECT y, x FROM test_interval|]
+  forM_ yxs $ \yx -> do
+      res <- query conn [sql| SELECT y=? FROM test_interval WHERE x=? |] yx
+      assertBool ("Interval did not round-trip from SQL to Haskell and back " ++ show yx ++ " ") $
+                 res == [Only True]