@@ -12,19 +12,27 @@
1212
1313module Database.PostgreSQL.Simple.Time.Implementation where
1414
15−import Prelude hiding (take)
16−--import Blaze.ByteString.Builder(fromByteString)
17−--import Blaze.ByteString.Builder.Char8(fromString, fromChar)
15+import Prelude hiding (take, (++))
16+import Blaze.ByteString.Builder(Builder, fromByteString)
17+import Blaze.ByteString.Builder.Char8(fromChar)
18+import Blaze.Text.Int(integral)
1819import Control.Arrow((***))
1920import Control.Applicative
2021import Control.Monad(when)
2122import Data.Bits((.&.))
2223import qualified Data.ByteString as B
23−import Data.ByteString.Internal (c2w)
24+import Data.ByteString.Internal (c2w, w2c)
2425import Data.Time hiding (getTimeZone, getZonedTime)
2526import Data.Typeable
2627import Data.Word(Word8)
2728import qualified Data.Attoparsec.Char8 as A
29+import Data.Monoid(Monoid(..))
30+import Data.Fixed (Pico)
31+import Unsafe.Coerce
32+
33+(++) :: Monoid a => a -> a -> a
34+(++) = mappend
35+infixr 5 ++
2836
2937data Unbounded a
3038 = NegInfinity
@@ -169,3 +177,103 @@ digits msg = do
169177 then return $! (10 * digit (c2w x) + digit (c2w y))
170178 else fail (msg ++ " is not 2 digits")
171179{-# INLINE digits #-}
180+
181+dayToBuilder :: Day -> Builder
182+dayToBuilder (toGregorian -> (y,m,d)) = do
183+ pad4 y ++ fromChar '-' ++ pad2 m ++ fromChar '-' ++ pad2 d
184+
185+timeOfDayToBuilder :: TimeOfDay -> Builder
186+timeOfDayToBuilder (TimeOfDay h m s) = do
187+ pad2 h ++ fromChar ':' ++ pad2 m ++ fromChar ':' ++ showSec s
188+ where
189+ showSec s = case toMicroseconds s of
190+ (s, 0) -> pad2 s
191+ (s,us) -> pad2 s ++ fromChar '.' ++ showMicroseconds us
192+
193+timeZoneToBuilder :: TimeZone -> Builder
194+timeZoneToBuilder tz
195+ | m == 0 = sign h ++ pad2 (abs h)
196+ | otherwise = sign h ++ pad2 (abs h) ++ fromChar ':' ++ pad2 (abs m)
197+ where
198+ (h,m) = timeZoneMinutes tz `quotRem` 60
199+ sign h | h >= 0 = fromChar '+'
200+ | otherwise = fromChar '-'
201+
202+utcTimeToBuilder :: UTCTime -> Builder
203+utcTimeToBuilder (UTCTime day time) =
204+ dayToBuilder day ++ fromChar ' '
205+ ++ timeOfDayToBuilder (timeToTimeOfDay time) ++ fromByteString "+00"
206+
207+zonedTimeToBuilder :: ZonedTime -> Builder
208+zonedTimeToBuilder (ZonedTime localTime tz) =
209+ localTimeToBuilder localTime ++ timeZoneToBuilder tz
210+
211+localTimeToBuilder :: LocalTime -> Builder
212+localTimeToBuilder (LocalTime day tod) =
213+ dayToBuilder day ++ fromChar ' ' ++ timeOfDayToBuilder tod
214+
215+unboundedToBuilder :: (a -> Builder) -> (Unbounded a -> Builder)
216+unboundedToBuilder finiteToBuilder unbounded
217+ = case unbounded of
218+ NegInfinity -> fromByteString "-infinity"
219+ Finite a -> finiteToBuilder a
220+ PosInfinity -> fromByteString "infinity"
221+
222+utcTimestampToBuilder :: UTCTimestamp -> Builder
223+utcTimestampToBuilder = unboundedToBuilder utcTimeToBuilder
224+
225+zonedTimestampToBuilder :: ZonedTimestamp -> Builder
226+zonedTimestampToBuilder = unboundedToBuilder zonedTimeToBuilder
227+
228+localTimestampToBuilder :: LocalTimestamp -> Builder
229+localTimestampToBuilder = unboundedToBuilder localTimeToBuilder
230+
231+dateToBuilder :: Date -> Builder
232+dateToBuilder = unboundedToBuilder dayToBuilder
233+
234+toMicroseconds :: Pico -> (Int,Int)
235+-- A kludge to work around the fact that Data.Fixed isn't very fast and doesn't
236+-- give me access to the MkFixed constructor.
237+toMicroseconds p = let (x,y) = (unsafeCoerce p :: Integer)
238+ `quotRem` 1000000000000
239+ (y',r) = y `quotRem` 1000000
240+ y'' = case compare r 500000 of
241+ LT -> y'
242+ EQ | even y' -> y'
243+ _ -> y' + 1
244+ in ( fromIntegral x, fromIntegral y'' )
245+
246+-- Assumes the input is within the range [0..999999]
247+showMicroseconds :: Int -> Builder
248+showMicroseconds us =
249+ case us `quotRem` 1000 of
250+ (ms, 0) -> case ms `quotRem` 100 of
251+ (a, 0) -> p a
252+ (a,ms) -> case ms `quotRem` 10 of
253+ (b,0) -> p a ++ p b
254+ (b,c) -> p a ++ p b ++ p c
255+ (ms,us) -> case ms `quotRem` 100 of
256+ (a,ms) -> case ms `quotRem` 10 of
257+ (b ,c) -> case us `quotRem` 100 of
258+ (d, 0) -> p a ++ p b ++ p c ++ p d
259+ (d,us) -> case us `quotRem` 10 of
260+ (e , 0) -> p a ++ p b ++ p c ++ p d ++ p e
261+ (e , f) -> p a ++ p b ++ p c ++ p d ++ p e ++ p f
262+
263+-- | p assumes its input is in the range [0..9]
264+p :: Integral n => n -> Builder
265+p n = fromChar (w2c (fromIntegral (n + 48)))
266+{-# INLINE p #-}
267+
268+-- | pad2 assumes its input is in the range [0..99]
269+pad2 :: Integral n => n -> Builder
270+pad2 n = let (a,b) = n `quotRem` 10 in p a ++ p b
271+{-# INLINE pad2 #-}
272+
273+-- | pad4 assumes its input is positive
274+pad4 :: (Integral n, Show n) => n -> Builder
275+pad4 n | n >= 1000 = integral n
276+ | n >= 100 = fromChar '0' ++ integral n
277+ | n >= 10 = fromByteString "00" ++ integral n
278+ | otherwise = fromByteString "000" ++ integral n
279+{-# INLINE pad4 #-}