git.iko.soy/typeable/postgresql-simple
on master help sign in
New Timestamp Printers
bf040c7Leon P Smith
postgresql-simple.cabal+1
compare with master
unifiedsplit
@@ -50,6 +50,7 @@ Library
50 Database.PostgreSQL.Simple.HStore.Implementation
50 Database.PostgreSQL.Simple.HStore.Implementation
51 Database.PostgreSQL.Simple.Time.Implementation
51 Database.PostgreSQL.Simple.Time.Implementation
52 Database.PostgreSQL.Simple.Time.Internal.Parser
52 Database.PostgreSQL.Simple.Time.Internal.Parser
53+ Database.PostgreSQL.Simple.Time.Internal.Printer
53 Database.PostgreSQL.Simple.TypeInfo.Types
54 Database.PostgreSQL.Simple.TypeInfo.Types
54
55
55 Build-depends:
56 Build-depends:
src/Database/PostgreSQL/Simple/Time/Implementation.hs+12−109
@@ -13,23 +13,18 @@
13module Database.PostgreSQL.Simple.Time.Implementation where
13module Database.PostgreSQL.Simple.Time.Implementation where
14
14
15import Prelude hiding (take)
15import Prelude hiding (take)
16−import Data.ByteString.Builder(Builder, byteString, char8, integerDec)
16+import Data.ByteString.Builder(Builder, byteString)
17+import Data.ByteString.Builder.Prim(primBounded)
17import Control.Arrow((***))
18import Control.Arrow((***))
18import Control.Applicative
19import Control.Applicative
19−import Data.Bits((.&.))
20import qualified Data.ByteString as B
20import qualified Data.ByteString as B
21−import Data.ByteString.Internal (c2w, w2c)
22import Data.Time hiding (getTimeZone, getZonedTime)
21import Data.Time hiding (getTimeZone, getZonedTime)
23import Data.Typeable
22import Data.Typeable
24−import Data.Word(Word8)
25import Data.Maybe (fromMaybe)
23import Data.Maybe (fromMaybe)
26import qualified Data.Attoparsec.ByteString.Char8 as A
24import qualified Data.Attoparsec.ByteString.Char8 as A
27import Database.PostgreSQL.Simple.Compat ((<>))
25import Database.PostgreSQL.Simple.Compat ((<>))
28−import Data.Monoid(Monoid(..))
29−import Data.Fixed (Pico)
30−import Unsafe.Coerce
31−import qualified Database.PostgreSQL.Simple.Time.Internal.Parser as TP
26+import qualified Database.PostgreSQL.Simple.Time.Internal.Parser as TP
32−import Database.PostgreSQL.Simple.Compat (fromPico)
27+import qualified Database.PostgreSQL.Simple.Time.Internal.Printer as TPP
33
28
34data Unbounded a
29data Unbounded a
35 = NegInfinity
30 = NegInfinity
@@ -115,7 +110,7 @@ getTimeZoneHMS = munge <$> TP.timeZoneHMS
115 munge (Just (TP.UTCOffsetHMS h m s)) = (h,m,s)
110 munge (Just (TP.UTCOffsetHMS h m s)) = (h,m,s)
116
111
117localToUTCTimeOfDayHMS :: TimeZoneHMS -> TimeOfDay -> (Integer, TimeOfDay)
112localToUTCTimeOfDayHMS :: TimeZoneHMS -> TimeOfDay -> (Integer, TimeOfDay)
118−localToUTCTimeOfDayHMS (dh, dm, ds) tod =
113+localToUTCTimeOfDayHMS (dh, dm, ds) tod =
119 TP.localToUTCTimeOfDayHMS (TP.UTCOffsetHMS dh dm ds) tod
114 TP.localToUTCTimeOfDayHMS (TP.UTCOffsetHMS dh dm ds) tod
120
115
121getZonedTime :: A.Parser ZonedTime
116getZonedTime :: A.Parser ZonedTime
@@ -130,57 +125,23 @@ getUTCTime = TP.utcTime
130getUTCTimestamp :: A.Parser UTCTimestamp
125getUTCTimestamp :: A.Parser UTCTimestamp
131getUTCTimestamp = getUnbounded getUTCTime
126getUTCTimestamp = getUnbounded getUTCTime
132
127
133−{--
134−toNum :: Num n => B.ByteString -> n
135−toNum = toNum_ 0
136−{-# INLINE toNum #-}
137−
138−toNum_ :: Num n => n -> B.ByteString -> n
139−toNum_ = B.foldl' (\a c -> 10*a + digit c)
140−
141−digit :: Num n => Word8 -> n
142−digit c = fromIntegral (c .&. 0x0f)
143−{-# INLINE digit #-}
144−
145−digits :: Num n => String -> A.Parser n
146−digits msg = do
147− x <- A.anyChar
148− y <- A.anyChar
149− if A.isDigit x && A.isDigit y
150− then return $! (10 * digit (c2w x) + digit (c2w y))
151− else fail (msg <> " is not 2 digits")
152−{-# INLINE digits #-}
153−--}
154−
155dayToBuilder :: Day -> Builder
128dayToBuilder :: Day -> Builder
156−dayToBuilder (toGregorian -> (y,m,d)) = do
129+dayToBuilder = primBounded TPP.day
157− pad4 y <> char8 '-' <> pad2 m <> char8 '-' <> pad2 d
158
130
159timeOfDayToBuilder :: TimeOfDay -> Builder
131timeOfDayToBuilder :: TimeOfDay -> Builder
160−timeOfDayToBuilder (TimeOfDay h m s) = do
132+timeOfDayToBuilder = primBounded TPP.timeOfDay
161− pad2 h <> char8 ':' <> pad2 m <> char8 ':' <> showSeconds s
162
133
163timeZoneToBuilder :: TimeZone -> Builder
134timeZoneToBuilder :: TimeZone -> Builder
164−timeZoneToBuilder tz
135+timeZoneToBuilder = primBounded TPP.timeZone
165− | m == 0 = sign h <> pad2 (abs h)
166− | otherwise = sign h <> pad2 (abs h) <> char8 ':' <> pad2 (abs m)
167− where
168− (h,m) = timeZoneMinutes tz `quotRem` 60
169− sign h | h >= 0 = char8 '+'
170− | otherwise = char8 '-'
171
136
172utcTimeToBuilder :: UTCTime -> Builder
137utcTimeToBuilder :: UTCTime -> Builder
173−utcTimeToBuilder (UTCTime day time) =
138+utcTimeToBuilder = primBounded TPP.utcTime
174− dayToBuilder day <> char8 ' '
175− <> timeOfDayToBuilder (timeToTimeOfDay time) <> byteString "+00"
176
139
177zonedTimeToBuilder :: ZonedTime -> Builder
140zonedTimeToBuilder :: ZonedTime -> Builder
178−zonedTimeToBuilder (ZonedTime localTime tz) =
141+zonedTimeToBuilder = primBounded TPP.zonedTime
179− localTimeToBuilder localTime <> timeZoneToBuilder tz
180
142
181localTimeToBuilder :: LocalTime -> Builder
143localTimeToBuilder :: LocalTime -> Builder
182−localTimeToBuilder (LocalTime day tod) =
144+localTimeToBuilder = primBounded TPP.localTime
183− dayToBuilder day <> char8 ' ' <> timeOfDayToBuilder tod
184
145
185unboundedToBuilder :: (a -> Builder) -> (Unbounded a -> Builder)
146unboundedToBuilder :: (a -> Builder) -> (Unbounded a -> Builder)
186unboundedToBuilder finiteToBuilder unbounded
147unboundedToBuilder finiteToBuilder unbounded
@@ -202,62 +163,4 @@ dateToBuilder :: Date -> Builder
202dateToBuilder = unboundedToBuilder dayToBuilder
163dateToBuilder = unboundedToBuilder dayToBuilder
203
164
204nominalDiffTimeToBuilder :: NominalDiffTime -> Builder
165nominalDiffTimeToBuilder :: NominalDiffTime -> Builder
205−nominalDiffTimeToBuilder xyz
166+nominalDiffTimeToBuilder = TPP.nominalDiffTime
206− | yz < 500000 = sign <> integerDec x
207− | otherwise = sign <> integerDec x <> char8 '.' <> showD6 y
208− where
209− sign = if xyz >= 0 then mempty else char8 '-'
210− -- A kludge to work around the fact that Data.Fixed isn't very fast and
211− -- NominalDiffTime doesn't give the MkNominalDiffTime constructor.
212− (x,yz) = ((unsafeCoerce (abs xyz) :: Integer) + 500000) `quotRem` 1000000000000
213− (fromIntegral -> y, _z) = yz `quotRem` 1000000
214−
215−showSeconds :: Pico -> Builder
216−showSeconds xyz
217− | yz == 0 = pad2 x
218− | z == 0 = pad2 x <> char8 '.' <> showD6 y
219− | otherwise = pad2 x <> char8 '.' <> pad6 y <> showD6 z
220− where
221− (x_,yz) = fromPico xyz `quotRem` 1000000000000
222− x = fromIntegral x_ :: Int
223− (fromIntegral -> y, fromIntegral -> z) = yz `quotRem` 1000000
224−
225−pad6 :: Int -> Builder
226−pad6 xy = let (x,y) = xy `quotRem` 1000
227− in pad3 x <> pad3 y
228−
229−showD6 :: Int -> Builder
230−showD6 xy = case xy `quotRem` 1000 of
231− (x,0) -> showD3 x
232− (x,y) -> pad3 x <> showD3 y
233−
234−pad3 :: Int -> Builder
235−pad3 abc = let (ab,c) = abc `quotRem` 10
236− (a,b) = ab `quotRem` 10
237− in p a <> p b <> p c
238−
239−showD3 :: Int -> Builder
240−showD3 abc = case abc `quotRem` 100 of
241− (a, 0) -> p a
242− (a,bc) -> case bc `quotRem` 10 of
243− (b,0) -> p a <> p b
244− (b,c) -> p a <> p b <> p c
245−
246−-- | p assumes its input is in the range [0..9]
247−p :: Integral n => n -> Builder
248−p n = char8 (w2c (fromIntegral (n + 48)))
249−{-# INLINE p #-}
250−
251−-- | pad2 assumes its input is in the range [0..99]
252−pad2 :: Integral n => n -> Builder
253−pad2 n = let (a,b) = n `quotRem` 10 in p a <> p b
254−{-# INLINE pad2 #-}
255−
256−-- | pad4 assumes its input is positive
257−pad4 :: Integer -> Builder
258−pad4 abcd | abcd >= 10000 = integerDec abcd
259− | otherwise = p a <> p b <> p c <> p d
260− where (ab,cd) = abcd `quotRem` 100
261− (a,b) = ab `quotRem` 10
262− (c,d) = cd `quotRem` 10
263−{-# INLINE pad4 #-}
src/Database/PostgreSQL/Simple/Time/Internal/Printer.hsnew file+123
@@ -0,0 +1,123 @@
1+{-# LANGUAGE BangPatterns, ViewPatterns #-}
2+
3+------------------------------------------------------------------------------
4+-- Module: Database.PostgreSQL.Simple.Time.Internal.Printer
5+-- Copyright: (c) 2012 Leon P Smith
6+-- License: BSD3
7+-- Maintainer: Leon P Smith <leon@melding-monads.com>
8+-- Stability: experimental
9+------------------------------------------------------------------------------
10+
11+module Database.PostgreSQL.Simple.Time.Internal.Printer
12+ (
13+ day
14+ , timeOfDay
15+ , timeZone
16+ , utcTime
17+ , localTime
18+ , zonedTime
19+ , nominalDiffTime
20+ ) where
21+
22+import Control.Arrow ((>>>))
23+import Data.ByteString.Builder (Builder, integerDec)
24+import Data.ByteString.Builder.Prim
25+ ( liftFixedToBounded, (>$<), (>*<)
26+ , BoundedPrim, primBounded, condB, emptyB, FixedPrim, char8, int32Dec)
27+import Data.Char ( chr )
28+import Data.Int ( Int32, Int64 )
29+import Data.Time
30+ ( UTCTime(..), ZonedTime(..), LocalTime(..), NominalDiffTime
31+ , Day, toGregorian, TimeOfDay(..), timeToTimeOfDay
32+ , TimeZone, timeZoneMinutes )
33+import Database.PostgreSQL.Simple.Compat ((<>), fromPico)
34+import Unsafe.Coerce (unsafeCoerce)
35+
36+liftB :: FixedPrim a -> BoundedPrim a
37+liftB = liftFixedToBounded
38+
39+digit :: FixedPrim Int
40+digit = (\x -> chr (x + 48)) >$< char8
41+
42+digits2 :: FixedPrim Int
43+digits2 = (`quotRem` 10) >$< (digit >*< digit)
44+
45+digits3 :: FixedPrim Int
46+digits3 = (`quotRem` 10) >$< (digits2 >*< digit)
47+
48+digits4 :: FixedPrim Int
49+digits4 = (`quotRem` 10) >$< (digits3 >*< digit)
50+
51+frac :: BoundedPrim Int64
52+frac = condB (== 0) emptyB ((,) '.' >$< (liftB char8 >*< trunc12))
53+ where
54+ trunc12 :: BoundedPrim Int64
55+ trunc12 = (`quotRem` 1000000) >$<
56+ condB (\(_,y) -> y == 0)
57+ (fst >$< trunc6)
58+ (liftB digits6 >*< trunc6)
59+
60+ digitB = liftB digit
61+
62+ digits6 = (fromIntegral >>> (`quotRem` 10)) >$< (digits5 >*< digit)
63+ digits5 = (`quotRem` 10) >$< (digits4 >*< digit)
64+
65+ trunc6 = (fromIntegral >>> (`quotRem` 100000)) >$< (digitB >*< trunc5)
66+ trunc5 = condB (== 0) emptyB ((`quotRem` 10000) >$< (digitB >*< trunc4))
67+ trunc4 = condB (== 0) emptyB ((`quotRem` 1000) >$< (digitB >*< trunc3))
68+ trunc3 = condB (== 0) emptyB ((`quotRem` 100) >$< (digitB >*< trunc2))
69+ trunc2 = condB (== 0) emptyB ((`quotRem` 10) >$< (digitB >*< trunc1))
70+ trunc1 = condB (== 0) emptyB digitB
71+
72+
73+year :: BoundedPrim Int32
74+year = condB (> 10000) int32Dec (checkBCE >$< liftB digits4)
75+ where
76+ checkBCE :: Int32 -> Int
77+ checkBCE y
78+ | y > 0 = fromIntegral y
79+ | otherwise = error msg
80+
81+ msg = "Database.PostgreSQL.Simple.Time.Printer.year: years BCE not supported"
82+
83+day :: BoundedPrim Day
84+day = toYMD >$< (year >*< liftB (char8 >*< digits2 >*< char8 >*< digits2))
85+ where
86+ toYMD (toGregorian -> (fromIntegral -> !y, !m,!d)) = (y,('-',(m,('-',d))))
87+
88+timeOfDay :: BoundedPrim TimeOfDay
89+timeOfDay = f >$< (hh_mm_ >*< ss)
90+ where
91+ f (TimeOfDay h m s) = ((h,(':',(m,':'))),s)
92+
93+ hh_mm_ = liftB (digits2 >*< char8 >*< digits2 >*< char8)
94+
95+ ss = (\s -> fromIntegral (fromPico s) `quotRem` 1000000000000) >$<
96+ (liftB (fromIntegral >$< digits2) >*< frac)
97+
98+timeZone :: BoundedPrim TimeZone
99+timeZone = ((`quotRem` 60) . timeZoneMinutes) >$< (liftB tzh >*< tzm)
100+ where
101+ f h = if h >= 0 then ('+', h) else (,) '-' $! (-h)
102+
103+ tzh = f >$< (char8 >*< digits2)
104+
105+ tzm = condB (==0) emptyB ((,) ':' >$< liftB (char8 >*< digits2))
106+
107+utcTime :: BoundedPrim UTCTime
108+utcTime = f >$< (day >*< liftB char8 >*< timeOfDay >*< liftB char8)
109+ where f (UTCTime d (timeToTimeOfDay -> tod)) = (d,(' ',(tod,'Z')))
110+
111+localTime :: BoundedPrim LocalTime
112+localTime = f >$< (day >*< liftB char8 >*< timeOfDay)
113+ where f (LocalTime d tod) = (d, (' ', tod))
114+
115+zonedTime :: BoundedPrim ZonedTime
116+zonedTime = f >$< (localTime >*< timeZone)
117+ where f (ZonedTime lt tz) = (lt, tz)
118+
119+
120+nominalDiffTime :: NominalDiffTime -> Builder
121+nominalDiffTime xy = integerDec x <> primBounded frac (abs (fromIntegral y))
122+ where
123+ (x,y) = fromPico (unsafeCoerce xy) `quotRem` 1000000000000