diff --git a/Data/UTC/Class/IsTime.hs b/Data/UTC/Class/IsTime.hs index 08e16e8..71c355d 100644 --- a/Data/UTC/Class/IsTime.hs +++ b/Data/UTC/Class/IsTime.hs @@ -82,6 +82,7 @@ class IsTime t where addSecondFractions f t | f == 0 = return t | f >= 0 = setSecondFraction frcs t >>= addSeconds secs + | frcs == 0 = setSecondFraction 0 t >>= addSeconds secs | otherwise = setSecondFraction (frcs + 1.0) t >>= addSeconds (secs - 1) where f' = f + (secondFraction t) diff --git a/Data/UTC/Format/Rfc3339.hs b/Data/UTC/Format/Rfc3339.hs index b5a6426..8e9d078 100644 --- a/Data/UTC/Format/Rfc3339.hs +++ b/Data/UTC/Format/Rfc3339.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} module Data.UTC.Format.Rfc3339 ( -- * Parsing @@ -61,7 +62,7 @@ instance Rfc3339Parser [Char] where -- > >>= renderRfc3339 :: Maybe String -- > > Just "1987-07-10T12:04:00Z" class Rfc3339Renderer string where - renderRfc3339 :: (MonadThrow m, IsDate t, IsTime t, Epoch t) => Local t -> m string + renderRfc3339 :: (MonadThrow m, IsDate (Local t), IsTime (Local t)) => Local t -> m string instance Rfc3339Renderer BS.ByteString where renderRfc3339 t diff --git a/Data/UTC/Format/Rfc3339/Builder.hs b/Data/UTC/Format/Rfc3339/Builder.hs index 154c8b0..93193b7 100644 --- a/Data/UTC/Format/Rfc3339/Builder.hs +++ b/Data/UTC/Format/Rfc3339/Builder.hs @@ -1,67 +1,73 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE Safe #-} module Data.UTC.Format.Rfc3339.Builder ( rfc3339Builder ) where -import Data.Monoid +import Control.Monad.Catch import Data.ByteString.Builder as BS +import Data.UTC.Type.Exception import Data.UTC.Type.Local import Data.UTC.Class.IsDate import Data.UTC.Class.IsTime -rfc3339Builder :: (Monad m, IsDate t, IsTime t) => Local t -> m BS.Builder -rfc3339Builder (Local os t) - = do -- calculate the single digits - let y3 = fromIntegral $ year t `div` 1000 `mod` 10 - y2 = fromIntegral $ year t `div` 100 `mod` 10 - y1 = fromIntegral $ year t `div` 10 `mod` 10 - y0 = fromIntegral $ year t `div` 1 `mod` 10 - m1 = fromIntegral $ month t `div` 10 `mod` 10 - m0 = fromIntegral $ month t `div` 1 `mod` 10 - d1 = fromIntegral $ day t `div` 10 `mod` 10 - d0 = fromIntegral $ day t `div` 1 `mod` 10 - h1 = fromIntegral $ hour t `div` 10 `mod` 10 - h0 = fromIntegral $ hour t `div` 1 `mod` 10 - n1 = fromIntegral $ minute t `div` 10 `mod` 10 - n0 = fromIntegral $ minute t `div` 1 `mod` 10 - s1 = fromIntegral $ second t `div` 10 `mod` 10 - s0 = fromIntegral $ second t `div` 1 `mod` 10 - f2 = truncate (secondFraction t * 10) `mod` 10 - f1 = truncate (secondFraction t * 100) `mod` 10 - f0 = truncate (secondFraction t * 1000) `mod` 10 - return $ mconcat - [ BS.word16HexFixed (y3*16*16*16 + y2*16*16 + y1*16 + y0) - , BS.char7 '-' - , BS.word8HexFixed (m1*16 + m0) - , BS.char7 '-' - , BS.word8HexFixed (d1*16 + d0) - , BS.char7 'T' - , BS.word8HexFixed (h1*16 + h0) - , BS.char7 ':' - , BS.word8HexFixed (n1*16 + n0) - , BS.char7 ':' - , BS.word8HexFixed (s1*16 + s0) - , if f0 == 0 - then if f1 == 0 - then if f2 == 0 - then mempty - else BS.char7 '.' `mappend` BS.intDec f2 - else BS.char7 '.' `mappend` BS.intDec f2 `mappend` BS.intDec f1 - else BS.char7 '.' `mappend` BS.intDec f2 `mappend` BS.intDec f1 `mappend` BS.intDec f0 - , case os of - Nothing -> BS.string7 "-00:00" - Just 0 -> BS.char7 'Z' - Just o -> let oh1 = fromIntegral $ abs (truncate o `quot` 600 `rem` 10 :: Integer) - oh0 = fromIntegral $ abs (truncate o `quot` 60 `rem` 10 :: Integer) - om1 = fromIntegral $ abs (truncate o `rem` 60 `quot` 10 `rem` 10 :: Integer) - om0 = fromIntegral $ abs (truncate o `rem` 60 `rem` 10 :: Integer) - in mconcat - [ if o < 0 - then BS.char7 '-' - else BS.char7 '+' - , BS.word8HexFixed (oh1*16 + oh0) - , BS.char7 ':' - , BS.word8HexFixed (om1*16 + om0) - ] - ] +rfc3339Builder :: (MonadThrow m, IsDate (Local t), IsTime (Local t)) => Local t -> m BS.Builder +rfc3339Builder t = + -- calculate the single digits + let y3 = fromIntegral $ year t `div` 1000 `mod` 10 + y2 = fromIntegral $ year t `div` 100 `mod` 10 + y1 = fromIntegral $ year t `div` 10 `mod` 10 + y0 = fromIntegral $ year t `div` 1 `mod` 10 + m1 = fromIntegral $ month t `div` 10 `mod` 10 + m0 = fromIntegral $ month t `div` 1 `mod` 10 + d1 = fromIntegral $ day t `div` 10 `mod` 10 + d0 = fromIntegral $ day t `div` 1 `mod` 10 + h1 = fromIntegral $ hour t `div` 10 `mod` 10 + h0 = fromIntegral $ hour t `div` 1 `mod` 10 + n1 = fromIntegral $ minute t `div` 10 `mod` 10 + n0 = fromIntegral $ minute t `div` 1 `mod` 10 + s1 = fromIntegral $ second t `div` 10 `mod` 10 + s0 = fromIntegral $ second t `div` 1 `mod` 10 + f2 = truncate (secondFraction t * 10) `mod` 10 + f1 = truncate (secondFraction t * 100) `mod` 10 + f0 = truncate (secondFraction t * 1000) `mod` 10 + dateTime = mconcat + [ BS.word16HexFixed (y3*16*16*16 + y2*16*16 + y1*16 + y0) + , BS.char7 '-' + , BS.word8HexFixed (m1*16 + m0) + , BS.char7 '-' + , BS.word8HexFixed (d1*16 + d0) + , BS.char7 'T' + , BS.word8HexFixed (h1*16 + h0) + , BS.char7 ':' + , BS.word8HexFixed (n1*16 + n0) + , BS.char7 ':' + , BS.word8HexFixed (s1*16 + s0) + , if f0 == 0 + then if f1 == 0 + then if f2 == 0 + then mempty + else BS.char7 '.' `mappend` BS.intDec f2 + else BS.char7 '.' `mappend` BS.intDec f2 `mappend` BS.intDec f1 + else BS.char7 '.' `mappend` BS.intDec f2 `mappend` BS.intDec f1 `mappend` BS.intDec f0 + ] + -- prepend dateTime part of the string to the timezone part which might fail + in fmap (dateTime <>) $ + case offset t of + Nothing -> return $ BS.string7 "-00:00" + Just 0 -> return $ BS.char7 'Z' + Just o -> if ((abs (truncate o)) `rem` 60 :: Integer) /= 0 + then throwM $ UtcException $ "Offset " ++ show o ++ " more accurate than a minute (unsupported by RFC3339)" + else let oh1 = fromIntegral $ abs (truncate o `quot` 36000 `rem` 10 :: Integer) + oh0 = fromIntegral $ abs (truncate o `quot` 3600 `rem` 10 :: Integer) + om1 = fromIntegral $ abs (truncate o `rem` 3600 `quot` 600 `rem` 10 :: Integer) + om0 = fromIntegral $ abs (truncate o `rem` 3600 `quot` 60 `rem` 10 :: Integer) + in return $ mconcat + [ if o < 0 + then BS.char7 '-' + else BS.char7 '+' + , BS.word8HexFixed (oh1*16 + oh0) + , BS.char7 ':' + , BS.word8HexFixed (om1*16 + om0) + ] diff --git a/Data/UTC/Format/Rfc3339/Parser.hs b/Data/UTC/Format/Rfc3339/Parser.hs index c9f8070..108709e 100644 --- a/Data/UTC/Format/Rfc3339/Parser.hs +++ b/Data/UTC/Format/Rfc3339/Parser.hs @@ -9,6 +9,8 @@ import Data.Ratio import Data.Attoparsec.ByteString ( Parser, skipWhile, choice, option, satisfy ) import Data.Attoparsec.ByteString.Char8 ( char, isDigit_w8 ) +import Data.Maybe (fromMaybe) + import Data.UTC.Class.Epoch import Data.UTC.Class.IsDate import Data.UTC.Class.IsTime @@ -37,6 +39,7 @@ rfc3339Parser >>= setMinute minute' >>= setSecond second' >>= setSecondFraction secfrac' + >>= addSecondFractions (-1 * fromMaybe 0 offset') return (Local offset' datetime) where dateFullYear diff --git a/tests/Test.hs b/tests/Test.hs index 5ee3151..d67d1cc 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -105,6 +105,8 @@ testTimeInstance t (addSecondFractions (-0.001) t >>= return . minute) == Just 59 && (addSecondFractions (-0.001) t >>= return . second) == Just 59 && (addSecondFractions (-0.001) t >>= return . secondFraction) == Just 0.999 + , testProperty ("Subtracting 1.0s as fraction should result in -1 seconds") + $ (addSecondFractions (-1.0) t == addSeconds (-1) t `asTypeOf` Just t) ] ] where