packages feed

postgresql-binary 0.5.2.1 → 0.7.4

raw patch · 35 files changed

+2451/−1714 lines, 35 filesdep +aesondep +basedep +binary-parserdep −HTFdep −attoparsecdep ~QuickCheckdep ~base-preludedep ~bytestring

Dependencies added: aeson, base, binary-parser, conversion, conversion-bytestring, conversion-text, either, foldl, tasty, tasty-hunit, tasty-quickcheck, tasty-smallcheck, vector

Dependencies removed: HTF, attoparsec

Dependency ranges changed: QuickCheck, base-prelude, bytestring, quickcheck-instances, scientific, text, time, transformers

Files

+ decoding/Main.hs view
@@ -0,0 +1,69 @@+module Main where++import BasePrelude+import MTLPrelude+import Control.DeepSeq+import Criterion+import Criterion.Main+import Data.Text (Text)+import Data.ByteString (ByteString)+import Data.Scientific (Scientific)+import Data.Time+import qualified PostgreSQL.Binary.Encoder as E+import qualified PostgreSQL.Binary.Decoder as D+++main =+  defaultMain+    [+      b "bool" D.bool (E.run E.bool True)+      ,+      b "int2" (D.int :: D.Decoder Int16) (E.run E.int2_int16 1000)+      ,+      b "int4" (D.int :: D.Decoder Int32) (E.run E.int4_int32 1000)+      ,+      b "int8" (D.int :: D.Decoder Int64) (E.run E.int8_int64 1000)+      ,+      b "float4" D.float4 (E.run E.float4 12.65468468)+      ,+      b "float8" D.float8 (E.run E.float8 12.65468468)+      ,+      b "numeric" D.numeric (E.run E.numeric (read "20.213290183"))+      ,+      b "char" D.char (E.run E.char 'Я')+      ,+      b "text" D.text_strict (E.run E.text_strict "alsdjflskjдывлоаы оады")+      ,+      b "bytea" D.bytea_strict (E.run E.bytea_strict "alskdfj;dasjfl;dasjflksdj")+      ,+      b "date" D.date (E.run E.date (read "2000-01-19"))+      ,+      b "time" D.time_int (E.run E.time_int (read "10:41:06"))+      ,+      b "timetz" D.timetz_int (E.run E.timetz_int (read "(10:41:06, +0300)"))+      ,+      b "timestamp" D.timestamp_int (E.run E.timestamp_int (read "2000-01-19 10:41:06"))+      ,+      b "timestamptz" D.timestamptz_int (E.run E.timestamptz_int (read "2000-01-19 10:41:06"))+      ,+      b "interval" D.interval_int (E.run E.interval_int (secondsToDiffTime 23472391128374))+      ,+      b "uuid" D.uuid (E.run E.uuid (read "550e8400-e29b-41d4-a716-446655440000"))+      ,+      let+        encoder =+          E.array 23 $+          E.arrayDimension foldl' $+          E.arrayValue $+          E.int4_int32+        decoder =+          D.array $+          D.arrayDimension replicateM $+          D.arrayNonNullValue $+          (D.int :: D.Decoder Int32)+        in+          b "array" decoder (E.run encoder [1,2,3,4])+    ]+  where+    b name decoder value = +      bench name $ nf (D.run decoder) value
+ encoding/Main.hs view
@@ -0,0 +1,63 @@+module Main where++import BasePrelude+import MTLPrelude+import Control.DeepSeq+import Criterion+import Criterion.Main+import Data.Text (Text)+import Data.ByteString (ByteString)+import Data.Scientific (Scientific)+import Data.Time+import qualified PostgreSQL.Binary.Encoder as E+++main =+  defaultMain+    [+      b "bool" E.bool True+      ,+      b "int2" E.int2_int16 1000+      ,+      b "int4" E.int4_int32 1000+      ,+      b "int8" E.int8_int64 1000+      ,+      b "float4" E.float4 12.65468468+      ,+      b "float8" E.float8 12.65468468+      ,+      b "numeric" E.numeric (read "20.213290183")+      ,+      b "char" E.char 'Я'+      ,+      b "text" E.text_strict "alsdjflskjдывлоаы оады"+      ,+      b "bytea" E.bytea_strict "alskdfj;dasjfl;dasjflksdj"+      ,+      b "date" E.date (read "2000-01-19")+      ,+      b "time" E.time_int (read "10:41:06")+      ,+      b "timetz" E.timetz_int (read "(10:41:06, +0300)")+      ,+      b "timestamp" E.timestamp_int (read "2000-01-19 10:41:06")+      ,+      b "timestamptz" E.timestamptz_int (read "2000-01-19 10:41:06")+      ,+      b "interval" E.interval_int (secondsToDiffTime 23472391128374)+      ,+      b "uuid" E.uuid (read "550e8400-e29b-41d4-a716-446655440000")+      ,+      let+        encoder =+          E.array 23 $+          E.arrayDimension foldl' $+          E.arrayValue $+          E.int4_int32+        in+          b "array" encoder [1,2,3,4]+    ]+  where+    b name encoder value = +      bench name $ nf (E.run encoder) value
− executables/Decoding.hs 
@@ -1,44 +0,0 @@-module Main where--import BasePrelude-import MTLPrelude-import Control.DeepSeq-import Criterion-import Criterion.Main-import Data.Text (Text)-import Data.ByteString (ByteString)-import Data.Scientific (Scientific)-import Data.Time-import qualified PostgreSQLBinary.Encoder as E-import qualified PostgreSQLBinary.Decoder as D-import qualified PostgreSQLBinary.Array as Array---main =-  defaultMain-    [-      b "bool"        D.bool               (E.bool True),-      b "int2"        (D.int :: D.D Int16) (E.int2 (Left 1000)),-      b "int4"        (D.int :: D.D Int32) (E.int4 (Left 1000)),-      b "int8"        (D.int :: D.D Int64) (E.int8 (Left 1000)),-      b "float4"      D.float4             (E.float4 12.65468468),-      b "float8"      D.float8             (E.float8 12.65468468),-      b "numeric"     D.numeric            (E.numeric (read "20.213290183")),-      b "char"        D.char               (E.char 'Я'),-      b "text"        D.text               (E.text (Left "alsdjflskjдывлоаы оады")),-      b "bytea"       D.bytea              (E.bytea (Left "alskdfj;dasjfl;dasjflksdj")),-      b "date"        D.date               (E.date (read "2000-01-19")),-      b "time"        (D.time True)        (E.time True (read "10:41:06")),-      b "timetz"      (D.timetz True)      (E.timetz True (read "(10:41:06, +0300)")),-      b "timestamp"   (D.timestamp True)   (E.timestamp True (read "2000-01-19 10:41:06")),-      b "timestamptz" (D.timestamptz True) (E.timestamptz True (read "2000-01-19 10:41:06")),-      b "interval"    (D.interval True)    (E.interval True (secondsToDiffTime 23472391128374)),-      b "uuid"        D.uuid               (E.uuid (read "550e8400-e29b-41d4-a716-446655440000")),-      b "array"       D.array              (E.array -                                             (Array.fromListUnsafe -                                               [Array.fromSingleton (Just "dfs") True 0,-                                                Array.fromSingleton Nothing True 0]))-    ]-  where-    b name decoder value = -      bench name $ nf decoder value
− executables/Encoding.hs 
@@ -1,43 +0,0 @@-module Main where--import BasePrelude-import MTLPrelude-import Control.DeepSeq-import Criterion-import Criterion.Main-import Data.Text (Text)-import Data.ByteString (ByteString)-import Data.Scientific (Scientific)-import Data.Time-import qualified PostgreSQLBinary.Encoder as E-import qualified PostgreSQLBinary.Decoder as D-import qualified PostgreSQLBinary.Array as Array---main =-  defaultMain-    [-      b "bool"        E.bool               True,-      b "int2"        E.int2               (Left 1000),-      b "int4"        E.int4               (Left 1000),-      b "int8"        E.int8               (Left 1000),-      b "float4"      E.float4             12.65468468,-      b "float8"      E.float8             12.65468468,-      b "numeric"     E.numeric            (read "20.213290183"),-      b "char"        E.char               'Я',-      b "text"        E.text               (Left "alsdjflskjдывлоаы оады"),-      b "bytea"       E.bytea              (Left "alskdfj;dasjfl;dasjflksdj"),-      b "date"        E.date               (read "2000-01-19"),-      b "time"        (E.time True)        (read "10:41:06"),-      b "timetz"      (E.timetz True)      (read "(10:41:06, +0300)"),-      b "timestamp"   (E.timestamp True)   (read "2000-01-19 10:41:06"),-      b "timestamptz" (E.timestamptz True) (read "2000-01-19 10:41:06"),-      b "interval"    (E.interval True)    (secondsToDiffTime 23472391128374),-      b "uuid"        E.uuid               (read "550e8400-e29b-41d4-a716-446655440000"),-      b "array"       E.array              (Array.fromListUnsafe -                                             [Array.fromSingleton (Just "dfs") True 0,-                                              Array.fromSingleton Nothing True 0])-    ]-  where-    b name encoder value = -      bench name $ nf encoder value
− executables/PostgreSQLBinary/PTI.hs 
@@ -1,77 +0,0 @@-module PostgreSQLBinary.PTI where--import BasePrelude----- | A Postgresql type info-data PTI = PTI { oidOf :: !Word32, arrayOIDOf :: !(Maybe Word32) }--abstime         = PTI 702  (Just 1023)-aclitem         = PTI 1033 (Just 1034)-bit             = PTI 1560 (Just 1561)-bool            = PTI 16   (Just 1000)-box             = PTI 603  (Just 1020)-bpchar          = PTI 1042 (Just 1014)-bytea           = PTI 17   (Just 1001)-char            = PTI 18   (Just 1002)-cid             = PTI 29   (Just 1012)-cidr            = PTI 650  (Just 651)-circle          = PTI 718  (Just 719)-cstring         = PTI 2275 (Just 1263)-date            = PTI 1082 (Just 1182)-daterange       = PTI 3912 (Just 3913)-float4          = PTI 700  (Just 1021)-float8          = PTI 701  (Just 1022)-gtsvector       = PTI 3642 (Just 3644)-inet            = PTI 869  (Just 1041)-int2            = PTI 21   (Just 1005)-int2vector      = PTI 22   (Just 1006)-int4            = PTI 23   (Just 1007)-int4range       = PTI 3904 (Just 3905)-int8            = PTI 20   (Just 1016)-int8range       = PTI 3926 (Just 3927)-interval        = PTI 1186 (Just 1187)-json            = PTI 114  (Just 199)-line            = PTI 628  (Just 629)-lseg            = PTI 601  (Just 1018)-macaddr         = PTI 829  (Just 1040)-money           = PTI 790  (Just 791)-name            = PTI 19   (Just 1003)-numeric         = PTI 1700 (Just 1231)-numrange        = PTI 3906 (Just 3907)-oid             = PTI 26   (Just 1028)-oidvector       = PTI 30   (Just 1013)-path            = PTI 602  (Just 1019)-point           = PTI 600  (Just 1017)-polygon         = PTI 604  (Just 1027)-record          = PTI 2249 (Just 2287)-refcursor       = PTI 1790 (Just 2201)-regclass        = PTI 2205 (Just 2210)-regconfig       = PTI 3734 (Just 3735)-regdictionary   = PTI 3769 (Just 3770)-regoper         = PTI 2203 (Just 2208)-regoperator     = PTI 2204 (Just 2209)-regproc         = PTI 24   (Just 1008)-regprocedure    = PTI 2202 (Just 2207)-regtype         = PTI 2206 (Just 2211)-reltime         = PTI 703  (Just 1024)-text            = PTI 25   (Just 1009)-tid             = PTI 27   (Just 1010)-time            = PTI 1083 (Just 1183)-timestamp       = PTI 1114 (Just 1115)-timestamptz     = PTI 1184 (Just 1185)-timetz          = PTI 1266 (Just 1270)-tinterval       = PTI 704  (Just 1025)-tsquery         = PTI 3615 (Just 3645)-tsrange         = PTI 3908 (Just 3909)-tstzrange       = PTI 3910 (Just 3911)-tsvector        = PTI 3614 (Just 3643)-txid_snapshot   = PTI 2970 (Just 2949)-unknown         = PTI 705  Nothing-uuid            = PTI 2950 (Just 2951)-varbit          = PTI 1562 (Just 1563)-varchar         = PTI 1043 (Just 1015)-void            = PTI 2278 Nothing-xid             = PTI 28   (Just 1011)-xml             = PTI 142  (Just 143)-
− executables/Tests.hs 
@@ -1,603 +0,0 @@-{-# OPTIONS_GHC -F -pgmF htfpp #-}-module Main where--import BasePrelude hiding (assert)-import Test.Framework-import Test.QuickCheck.Instances-import Data.Time-import qualified Data.Text as T-import qualified Data.Text.Encoding as TE-import qualified Data.Text.Lazy as TL-import qualified Data.ByteString as B-import qualified Data.ByteString.Char8 as BC-import qualified Data.ByteString.Lazy as BL-import qualified Data.ByteString.Lazy.Char8 as BLC-import qualified Data.Scientific as Scientific-import qualified Data.UUID as UUID-import qualified Database.PostgreSQL.LibPQ as PQ-import qualified PostgreSQLBinary.PTI as PTI-import qualified PostgreSQLBinary.Encoder as Encoder-import qualified PostgreSQLBinary.Decoder as Decoder-import qualified PostgreSQLBinary.Array as Array---type Text = T.Text-type LazyText = TL.Text-type ByteString = B.ByteString-type LazyByteString = BL.ByteString-type Scientific = Scientific.Scientific--main = -  htfMain $ htf_thisModulesTests--floatEqProp :: RealFrac a => Show a => a -> a -> Property-floatEqProp a b =-  counterexample (show a ++ " /~ " ++ show b) $-    a + error >= b && a - error <= b-  where-    error = max (abs a) 1 / 10^3--mappingP :: -  (Show a, Eq a) => -  Word32 -> (a -> Maybe ByteString) -> (Maybe ByteString -> Either Text a) -> a -> Property-mappingP oid encode decode v =-  Right v === do-    unsafePerformIO $ do-      c <- connect-      initConnection c-      result <--        let param = (,,) <$> pure (PQ.Oid $ fromIntegral oid) <*> encode v <*> pure PQ.Binary-            in PQ.execParams c "SELECT $1" [param] PQ.Binary-      case result of-        Just result -> do-          binaryResult <- PQ.getvalue result 0 0-          PQ.finish c-          return $ decode binaryResult-        Nothing -> do-          m <- PQ.errorMessage c-          fail $ maybe "Fatal PQ error" (\m -> "Fatal PQ error: " <> show m) m--mappingTextP ::-  (Show a, Eq a) => -  Word32 -> (a -> Maybe ByteString) -> (a -> Maybe ByteString) -> a -> Property-mappingTextP oid encode render value =-  render value === do unsafePerformIO $ checkText oid (encode value)--checkText :: Word32 -> Maybe ByteString -> IO (Maybe ByteString)-checkText oid v =-  do-    c <- connect-    initConnection c-    Just result <--      let param = (,,) <$> pure (PQ.Oid $ fromIntegral oid) <*> v <*> pure PQ.Binary-          in PQ.execParams c "SELECT $1" [param] PQ.Text-    encodedResult <- PQ.getvalue result 0 0-    PQ.finish c-    return $ encodedResult--query :: ByteString -> [Maybe (PQ.Oid, ByteString, PQ.Format)] -> PQ.Format -> IO (Maybe ByteString)-query statement params outFormat =-  do-    connection <- connect-    initConnection connection-    Just result <- PQ.execParams connection statement params outFormat-    encodedResult <- PQ.getvalue result 0 0-    PQ.finish connection-    return $ encodedResult--connect :: IO PQ.Connection-connect =-  PQ.connectdb bs-  where-    bs = -      B.intercalate " " components-      where-        components = -          [-            "host=" <> host,-            "port=" <> (fromString . show) port,-            "user=" <> user,-            "password=" <> password,-            "dbname=" <> db-          ]-          where-            host = "localhost"-            port = 5432-            user = "postgres"-            password = ""-            db = "postgres"--initConnection :: PQ.Connection -> IO ()-initConnection c =-  void $ PQ.exec c $ mconcat $ map (<> ";") $ -    [ -      "SET client_min_messages TO WARNING",-      "SET client_encoding = 'UTF8'",-      "SET intervalstyle = 'postgres'"-    ]--getIntegerDatetimes :: PQ.Connection -> IO Bool-getIntegerDatetimes c =-  fmap parseResult $ PQ.parameterStatus c "integer_datetimes"-  where-    parseResult = -      \case-        Just "on" -> True-        _ -> False--nonNullParser p =-  fromMaybe (Left "Unexpected NULL") . fmap p--nonNullRenderer r =-  return . r---- * Generators----------------------------scientificGen :: Gen Scientific-scientificGen =-  Scientific.scientific <$> arbitrary <*> arbitrary--microsTimeOfDayGen :: Gen TimeOfDay-microsTimeOfDayGen =-  fmap timeToTimeOfDay $ fmap picosecondsToDiffTime $ fmap (* (10^6)) $ -    choose (0, (10^6)*24*60*60)--microsLocalTimeGen :: Gen LocalTime-microsLocalTimeGen = -  LocalTime <$> arbitrary <*> microsTimeOfDayGen--microsUTCTimeGen :: Gen UTCTime-microsUTCTimeGen =-  localTimeToUTC <$> timeZoneGen <*> microsLocalTimeGen--intervalDiffTimeGen :: Gen DiffTime-intervalDiffTimeGen = do-  unsafeCoerce ((* (10^6)) <$> choose (uMin, uMax) :: Gen Integer)-  where-    uMin = unsafeCoerce minInterval `div` 10^6-    uMax = unsafeCoerce maxInterval `div` 10^6--timeZoneGen :: Gen TimeZone-timeZoneGen =-  minutesToTimeZone <$> choose (- 60 * 12 + 1, 60 * 12)--uuidGen :: Gen UUID.UUID-uuidGen =-  UUID.fromWords <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary--arrayGen :: Gen (Word32, Array.Data)-arrayGen =-  do-    ndims <- choose (1, 4)-    dims <- replicateM ndims dimGen-    (valueGen', oid, arrayOID) <- valueGen-    values <- replicateM (dimsToNValues dims) valueGen'-    let nulls = elem Nothing values-    return (arrayOID, (dims, values, nulls, oid))-  where-    dimGen =-      (,) <$> choose (1, 7) <*> pure 1-    valueGen =-      do-        (pti, gen) <- elements [(PTI.int8, mkGen (Encoder.int8 . Left)),-                                (PTI.bool, mkGen Encoder.bool),-                                (PTI.date, mkGen Encoder.date),-                                (PTI.text, mkGen Encoder.text),-                                (PTI.bytea, mkGen Encoder.bytea)]-        return (gen, PTI.oidOf pti, fromJust $ PTI.arrayOIDOf pti)-      where-        mkGen renderer =-          fmap (fmap renderer) arbitrary-    dimsToNValues =-      product . map dimensionWidth-      where-        dimensionWidth (x, _) = fromIntegral x---- * Constants----------------------------maxInterval :: DiffTime = -  unsafeCoerce $ -    (truncate (1780000 * 365.2425 * 24 * 60 * 60 * 10 ^ 12 :: Rational) :: Integer)--minInterval :: DiffTime = -  negate maxInterval--integerDatetimes :: Bool-integerDatetimes =-  unsafePerformIO $ do-    connection <- connect-    initConnection connection-    integerDatetimes <- getIntegerDatetimes connection-    PQ.finish connection-    return integerDatetimes---- * Misc----------------------------timestamptzApxRep (UTCTime d d') =-  (d, picoApxRep (unsafeCoerce d'))--timestampApxRep (LocalTime d t) =-  (d, timeApxRep t)--timetzApxRep (t, tz) = -  (timeApxRep t, tz)--timeApxRep (TimeOfDay h m s) =-  (h, m, picoApxRep s)--picoApxRep :: Pico -> Integer-picoApxRep s =-  let p = unsafeCoerce s :: Integer-      in round (p % 10^6)----- * Tests------------------------------ | This is a dummy, the sole point of which is to output the value of 'integer_datetimes'-test_integerDatetimes =-  do-    connection <- connect-    initConnection connection-    x <- getIntegerDatetimes connection-    putStrLn $ "'integer_datetimes' is " <> show x-    PQ.finish connection--prop_uuid =-  forAll uuidGen $ -    mappingP (PTI.oidOf PTI.uuid) -             (nonNullRenderer Encoder.uuid)-             (nonNullParser Decoder.uuid)--test_uuidParsing =-  assertEqual (Right (read "550e8400-e29b-41d4-a716-446655440000" :: UUID.UUID)) =<< do-    fmap (Decoder.uuid . fromJust) $ -      query "SELECT '550e8400-e29b-41d4-a716-446655440000' :: uuid" [] PQ.Binary--test_intervalParsing =-  let p = 10^6 * (332211 + 10^6 * (6 + 60 * (5 + 60 * (4 + 24 * (3 + 31 * (2 + 12))))))-      in -      assertEqual (Just (Right (picosecondsToDiffTime p))) =<< do-        (fmap . fmap) (Decoder.interval integerDatetimes) $ -          query "SELECT '1 year 2 months 3 days 4 hours 5 minutes 6 seconds 332211 microseconds' :: interval" [] PQ.Binary--prop_interval =-  forAll intervalDiffTimeGen $ -    mappingP (PTI.oidOf PTI.interval) -             (nonNullRenderer (Encoder.interval integerDatetimes))-             (nonNullParser (Decoder.interval integerDatetimes))--test_maxInterval =-  let x = maxInterval-    in -      assertEqual (Just (Right x)) =<< do-        let -          p = -            (,,)-              (PQ.Oid (fromIntegral (PTI.oidOf PTI.interval)))-              ((Encoder.interval integerDatetimes) x)-              (PQ.Binary)-        (fmap . fmap) (Decoder.interval integerDatetimes) $ -          query "SELECT $1" [Just p] PQ.Binary--test_minInterval =-  let x = minInterval-    in -      assertEqual (Just (Right x)) =<< do-        let -          p = -            (,,)-              (PQ.Oid (fromIntegral (PTI.oidOf PTI.interval)))-              ((Encoder.interval integerDatetimes) x)-              (PQ.Binary)-        (fmap . fmap) (Decoder.interval integerDatetimes) $ -          query "SELECT $1" [Just p] PQ.Binary--prop_timestamp =-  forAll microsLocalTimeGen $ \x ->-    Just (Right (timestampApxRep x)) === do-      unsafePerformIO $ do-        let p = (,,) (PQ.Oid $ fromIntegral $ PTI.oidOf PTI.timestamp)-                     (Encoder.timestamp integerDatetimes x)-                     (PQ.Binary)-            in (fmap . fmap) (fmap timestampApxRep . Decoder.timestamp integerDatetimes)-                             (query "SELECT $1" [Just p] PQ.Binary)--test_timestampParsing1 =-  assertEqual (Right (read "2000-01-19 10:41:06" :: LocalTime)) =<< do-    fmap (Decoder.timestamp integerDatetimes . fromJust) $ -      query "SELECT '2000-01-19 10:41:06' :: timestamp" [] PQ.Binary--test_timestamptzOffset =-  do-    c <- connect-    initConnection c-    PQ.exec c "DROP TABLE IF EXISTS a"-    PQ.exec c "CREATE TABLE a (b TIMESTAMPTZ)"-    PQ.exec c "set timezone to 'America/Los_Angeles'"-    let p = (,,) (PQ.Oid $ fromIntegral o) -                 (Encoder.timestamptz integerDatetimes x) -                 (PQ.Binary)-        o = PTI.oidOf PTI.timestamptz-        x = read "2011-09-28 00:17:25"-    PQ.execParams c "insert into a (b) values ($1)" [Just p] PQ.Text-    PQ.exec c "set timezone to 'Europe/Stockholm'"-    assertEqual (Just "2011-09-28 02:17:25+02") -      =<< singleResult -      =<< PQ.execParams c "SELECT * FROM a" [] PQ.Text-    assertEqual (Just (Right x)) -      =<< return . fmap (Decoder.timestamptz integerDatetimes)-      =<< singleResult -      =<< PQ.execParams c "SELECT * FROM a" [] PQ.Binary-  where-    singleResult r = PQ.getvalue (fromJust r) 0 0--prop_timestamptz =-  forAll microsUTCTimeGen $ \x ->-    Just (Right (timestamptzApxRep x)) === do-      unsafePerformIO $ do-        let p = (,,) (PQ.Oid $ fromIntegral $ PTI.oidOf PTI.timestamptz)-                     (Encoder.timestamptz integerDatetimes x)-                     (PQ.Binary)-            in (fmap . fmap) (fmap timestamptzApxRep . Decoder.timestamptz integerDatetimes)-                             (query "SELECT $1" [Just p] PQ.Binary)--prop_timetz =-  forAll ((,) <$> microsTimeOfDayGen <*> timeZoneGen) $ \x ->-    Just (Right (timetzApxRep x)) === do-      unsafePerformIO $ do-        let p = (,,) (PQ.Oid $ fromIntegral $ PTI.oidOf PTI.timetz)-                     (Encoder.timetz integerDatetimes x)-                     (PQ.Binary)-            in (fmap . fmap) (fmap timetzApxRep . Decoder.timetz integerDatetimes)-                             (query "SELECT $1" [Just p] PQ.Binary)--test_timetzParsing =-  assertEqual (Right $ timetzApxRep (read "(10:41:06.002897, +0500)" :: (TimeOfDay, TimeZone))) =<< do-    connection <- connect-    initConnection connection-    integerDatetimes <- getIntegerDatetimes connection-    Just result <- PQ.execParams connection "SELECT '10:41:06.002897+05' :: timetz" [] PQ.Binary-    encodedResult <- PQ.getvalue result 0 0-    PQ.finish connection-    return $ fmap timetzApxRep $ -      Decoder.timetz integerDatetimes (fromJust encodedResult)--prop_timeFromIntegerIsomorphism =-  forAll microsTimeOfDayGen $ \x ->-    Right x === Decoder.time True (Encoder.time True x)--prop_timeFromDoubleIsomorphism =-  forAll microsTimeOfDayGen $ \x ->-    let Right x' = Decoder.time False (Encoder.time False x)-        in floatEqProp (toFloat x) (toFloat x')-  where-    toFloat (TimeOfDay h m s) =-      s + fromIntegral (60 * (m + 60 * h))--prop_time =-  forAll microsTimeOfDayGen $ \x ->-    Right (timeApxRep x) === do-      unsafePerformIO $ do-        connection <- connect-        initConnection connection-        integerDatetimes <- getIntegerDatetimes connection-        Just result <- -          let params = [Just (PQ.Oid $ fromIntegral $ PTI.oidOf PTI.time, Encoder.time integerDatetimes x, PQ.Binary)]-              in PQ.execParams connection "SELECT $1" params PQ.Binary-        encodedResult <- PQ.getvalue result 0 0-        PQ.finish connection-        return $ fmap timeApxRep $-          Decoder.time integerDatetimes (fromJust encodedResult)--prop_timeParsing =-  forAll microsTimeOfDayGen $ \x ->-    Right (timeApxRep x) === do-      unsafePerformIO $ do-        connection <- connect-        initConnection connection-        integerDatetimes <- getIntegerDatetimes connection-        Just result <- -          let params = [Just (PQ.Oid $ fromIntegral $ PTI.oidOf PTI.time, (fromString . show) x, PQ.Text)]-              in PQ.execParams connection "SELECT $1" params PQ.Binary-        encodedResult <- PQ.getvalue result 0 0-        PQ.finish connection-        return $ fmap timeApxRep $-          Decoder.time integerDatetimes (fromJust encodedResult)--prop_scientific (c, e) =-  let x = Scientific.scientific c e-    in-      mappingP (PTI.oidOf PTI.numeric) -               (nonNullRenderer Encoder.numeric)-               (nonNullParser Decoder.numeric)-               (x)--test_scientificParsing1 =-  assertEqual (Right (read "-1234560.789" :: Scientific)) =<< do-    fmap (Decoder.numeric . fromJust) $ -      query "SELECT -1234560.789 :: numeric" [] PQ.Binary--test_scientificParsing2 =-  assertEqual (Right (read "-0.0789" :: Scientific)) =<< do-    fmap (Decoder.numeric . fromJust) $ -      query "SELECT -0.0789 :: numeric" [] PQ.Binary--test_scientificParsing3 =-  assertEqual (Right (read "10000" :: Scientific)) =<< do-    fmap (Decoder.numeric . fromJust) $ -      query "SELECT 10000 :: numeric" [] PQ.Binary--prop_scientificParsing (c, e) =-  let x = Scientific.scientific c e-    in-      Right x === do-        unsafePerformIO $ -          fmap (Decoder.numeric . fromJust) $ -            query "SELECT $1 :: numeric" -                  [Just (PQ.Oid $ fromIntegral $ PTI.oidOf PTI.numeric, (fromString . show) x, PQ.Text)] -                  PQ.Binary--prop_float =-  mappingP (PTI.oidOf PTI.float4) -           (nonNullRenderer Encoder.float4)-           (nonNullParser Decoder.float4)--prop_floatText =-  \x -> -    floatEqProp x $ do-      fromJust $ unsafePerformIO $ (fmap . fmap) reader $ checkText (PTI.oidOf pti) (encoder x)-  where-    pti = PTI.float4-    reader = read . BC.unpack-    encoder = nonNullRenderer Encoder.float4--prop_double =-  mappingP (PTI.oidOf PTI.float8) -           (nonNullRenderer Encoder.float8)-           (nonNullParser Decoder.float8)--prop_doubleText =-  \x -> -    floatEqProp x $ do-      fromJust $ unsafePerformIO $ (fmap . fmap) reader $ checkText (PTI.oidOf pti) (encoder x)-  where-    pti = PTI.float8-    reader = read . BC.unpack-    encoder = nonNullRenderer Encoder.float8--prop_char x =-  (x /= '\NUL') ==>-  mappingP (PTI.oidOf PTI.text) -           (nonNullRenderer Encoder.char)-           (nonNullParser Decoder.char)-           (x)--prop_charText x =-  (x /= '\NUL') ==>-  mappingTextP (PTI.oidOf PTI.text) -               (nonNullRenderer Encoder.char) -               (Just . TE.encodeUtf8 . T.singleton)-               (x)--test_emptyArrayElements =-  assertEqual [] (Array.elements ([], [], False, 0))--test_arrayElements =-  assertEqual result (Array.elements arrayData)-  where-    arrayData = ([(3, 1)], [Just "1", Just "2", Just "3"], False, 0)-    result = [([], [Just "1"], False, 0), ([], [Just "2"], False, 0), ([], [Just "3"], False, 0)]--prop_arrayDataFromAndToListIsomporphism =-  forAll arrayGen $ \(oid, x) ->-    x === (Array.fromListUnsafe . Array.elements) x--prop_byteString =-  mappingP (PTI.oidOf PTI.bytea)-           (nonNullRenderer (Encoder.bytea . Left))-           (nonNullParser Decoder.bytea)--prop_lazyByteString =-  mappingP (PTI.oidOf PTI.bytea)-           (nonNullRenderer (Encoder.bytea . Right))-           (nonNullParser (fmap BL.fromStrict . Decoder.bytea))--prop_text v =-  (isNothing $ T.find (== '\NUL') v) ==>-    mappingP (PTI.oidOf PTI.text) -             (nonNullRenderer (Encoder.text . Left))-             (nonNullParser Decoder.text)-             (v)--prop_lazyText v =-  (isNothing $ TL.find (== '\NUL') v) ==>-    mappingP (PTI.oidOf PTI.text) -             (nonNullRenderer (Encoder.text . Right))-             (nonNullParser (fmap TL.fromStrict . Decoder.text))-             (v)--prop_bool =-  mappingP (PTI.oidOf PTI.bool) -           (nonNullRenderer Encoder.bool)-           (nonNullParser Decoder.bool)--prop_int =-  mappingP (PTI.oidOf PTI.int8) -           (nonNullRenderer (Encoder.int8 . Left) . (fromIntegral :: Int -> Int64))-           (nonNullParser Decoder.int)--prop_int8 =-  mappingP (PTI.oidOf PTI.int2) -           (nonNullRenderer (Encoder.int2 . Left) . (fromIntegral :: Int8 -> Int16))-           (nonNullParser Decoder.int)--prop_int16 =-  mappingP (PTI.oidOf PTI.int2) -           (nonNullRenderer (Encoder.int2 . Left))-           (nonNullParser Decoder.int)--prop_int32 =-  mappingP (PTI.oidOf PTI.int4) -           (nonNullRenderer (Encoder.int4 . Left))-           (nonNullParser Decoder.int)--prop_int64 =-  mappingP (PTI.oidOf PTI.int8) -           (nonNullRenderer (Encoder.int8 . Left))-           (nonNullParser Decoder.int)--prop_int64Text =-  mappingTextP (PTI.oidOf PTI.int8) -               (nonNullRenderer (Encoder.int8 . Left)) -               (Just . fromString . show)--prop_word =-  mappingP (PTI.oidOf PTI.int8) -           (nonNullRenderer (Encoder.int8 . Right) . (fromIntegral :: Word -> Word64))-           (nonNullParser Decoder.int)--prop_word8 =-  mappingP (PTI.oidOf PTI.int2) -           (nonNullRenderer (Encoder.int2 . Right) . (fromIntegral :: Word8 -> Word16))-           (nonNullParser Decoder.int)--prop_word16 =-  mappingP (PTI.oidOf PTI.int2) -           (nonNullRenderer (Encoder.int2 . Right))-           (nonNullParser Decoder.int)--prop_word32 =-  mappingP (PTI.oidOf PTI.int4) -           (nonNullRenderer (Encoder.int4 . Right))-           (nonNullParser Decoder.int)--prop_word64 =-  mappingP (PTI.oidOf PTI.int8) -           (nonNullRenderer (Encoder.int8 . Right))-           (nonNullParser Decoder.int)--prop_word64Text =-  mappingTextP (PTI.oidOf PTI.int8) -               (nonNullRenderer (Encoder.int8 . Right)) -               (Just . fromString . show)--prop_day =-  mappingP (PTI.oidOf PTI.date) -           (nonNullRenderer Encoder.date)-           (nonNullParser Decoder.date)--prop_dayText =-  mappingTextP (PTI.oidOf PTI.date) -               (nonNullRenderer Encoder.date) -               (Just . fromString . show)--prop_arrayData =-  forAll arrayGen $ uncurry $ \oid ->-    mappingP (oid)-             (nonNullRenderer Encoder.array)-             (nonNullParser Decoder.array)-
+ library/PostgreSQL/Binary/BuilderPrim.hs view
@@ -0,0 +1,10 @@+module PostgreSQL.Binary.BuilderPrim where++import PostgreSQL.Binary.Prelude+import qualified Data.ByteString.Builder.Prim as A+++{-# INLINE nullByteIgnoringBoundedPrim #-}+nullByteIgnoringBoundedPrim :: A.BoundedPrim Word8+nullByteIgnoringBoundedPrim =+  A.condB (== 0) A.emptyB (A.liftFixedToBounded A.word8)
+ library/PostgreSQL/Binary/Data.hs view
@@ -0,0 +1,58 @@+-- |+-- Models of supported data structures according to the serialisation format.+module PostgreSQL.Binary.Data where++import PostgreSQL.Binary.Prelude+++-- | +-- A representation of a data serializable to the PostgreSQL array binary format.+-- +-- Consists of a vector of dimensions, a vector of encoded elements,+-- a flag specifying, whether it contains any nulls, and an oid.+type Array =+  (Vector ArrayDimension, Vector Content, Bool, OID)++-- | +-- A width and a lower bound.+-- +-- Currently the lower bound is only allowed to have a value of @1@.+type ArrayDimension =+  (Word32, Word32)++-- |+-- An encoded value. 'Nothing' if it represents a @NULL@.+type Content =+  Maybe ByteString++-- |+-- A Postgres OID of a type.+type OID =+  Word32++-- |+-- A representation of a composite Postgres data (Record or Row).+type Composite =+  Vector (OID, Content)++-- |+-- HStore.+type HStore =+  Vector (ByteString, Content)++-- |+-- The four components of UUID.+type UUID =+  (Word32, Word32, Word32, Word32)++-- |+-- Representation of the PostgreSQL Numeric encoding.+-- +-- Consists of the following components:+-- +-- * Point index+-- * Sign code+-- * Components+-- +type Numeric =+  (Int16, Word16, Vector Int16)
+ library/PostgreSQL/Binary/Decoder.hs view
@@ -0,0 +1,484 @@+module PostgreSQL.Binary.Decoder+(+  Decoder,+  run,+  -- * Primitive+  int,+  float4,+  float8,+  bool,+  bytea_strict,+  bytea_lazy,+  -- * Textual+  text_strict,+  text_lazy,+  char,+  -- * Misc+  numeric,+  uuid,+  json,+  -- * Time+  date,+  time_int,+  time_float,+  timetz_int,+  timetz_float,+  timestamp_int,+  timestamp_float,+  timestamptz_int,+  timestamptz_float,+  interval_int,+  interval_float,+  -- * Exotic+  -- ** Array+  ArrayDecoder,+  array,+  arrayDimension,+  arrayValue,+  arrayNonNullValue,+  -- ** Composite+  CompositeDecoder,+  composite,+  compositeValue,+  compositeNonNullValue,+  -- ** HStore+  hstore,+  -- **+  enum,+)+where++import PostgreSQL.Binary.Prelude hiding (take, bool, drop, state, fail, failure)+import BinaryParser+import qualified PostgreSQL.Binary.Data as Data+import qualified PostgreSQL.Binary.Integral as Integral+import qualified PostgreSQL.Binary.Interval as Interval+import qualified PostgreSQL.Binary.Numeric as Numeric+import qualified PostgreSQL.Binary.Time as Time+import qualified Data.Vector as Vector+import qualified Data.ByteString as ByteString+import qualified Data.ByteString.Lazy as LazyByteString+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import qualified Data.Text.Encoding.Error as Text+import qualified Data.Text.Lazy.Encoding as LazyText+import qualified Data.UUID as UUID+import qualified Data.Aeson as Aeson+++type Decoder =+  BinaryParser+++-- * Helpers+-------------------------++-- |+-- Any int number of a limited byte-size.+{-# INLINE intOfSize #-}+intOfSize :: (Integral a, Bits a) => Int -> Decoder a+intOfSize x =+  fmap Integral.pack (bytesOfSize x)++{-# INLINABLE onContent #-}+onContent :: Decoder a -> Decoder ( Maybe a )+onContent decoder =+  intOfSize 4 >>= \case+    (-1) -> pure Nothing+    n -> fmap Just (sized n decoder)++{-# INLINABLE content #-}+content :: Decoder (Maybe ByteString)+content =+  intOfSize 4 >>= \case+    (-1) -> pure Nothing+    n -> fmap Just (bytesOfSize n)++{-# INLINE nonNull #-}+nonNull :: Maybe a -> Decoder a+nonNull =+  maybe (failure "Unexpected NULL") return+++-- * Primitive+-------------------------++{-# INLINE int #-}+int :: (Integral a, Bits a) => Decoder a+int =+  fmap Integral.pack remainders++float4 :: Decoder Float+float4 =+  unsafeCoerce (int :: Decoder Int32)++float8 :: Decoder Double+float8 =+  unsafeCoerce (int :: Decoder Int64)++{-# INLINE bool #-}+bool :: Decoder Bool+bool =+  fmap (== 1) byte++{-# NOINLINE numeric #-}+numeric :: Decoder Scientific+numeric =+  do+    componentsAmount <- intOfSize 2+    pointIndex <- intOfSize 2+    signCode <- intOfSize 2+    unitOfSize 2+    components <- Vector.replicateM componentsAmount (intOfSize 2)+    either failure return (Numeric.scientific pointIndex signCode components)++{-# INLINABLE uuid #-}+uuid :: Decoder UUID+uuid =+  UUID.fromWords <$> intOfSize 4 <*> intOfSize 4 <*> intOfSize 4 <*> intOfSize 4++{-# INLINABLE json #-}+json :: Decoder Aeson.Value+json =+  bytea_strict >>= either (BinaryParser.failure . fromString) pure . Aeson.eitherDecodeStrict'+++-- ** Textual+-------------------------++-- |+-- A UTF-8-decoded char.+{-# INLINABLE char #-}+char :: Decoder Char+char =+  fmap Text.uncons text_strict >>= \case+    Just (c, "") -> return c+    Nothing -> failure "Empty input"+    _ -> failure "Consumed too much"++-- |+-- Any of the variable-length character types:+-- BPCHAR, VARCHAR, NAME and TEXT.+{-# INLINABLE text_strict #-}+text_strict :: Decoder Text+text_strict =+  remainders >>= either (failure . exception) return . Text.decodeUtf8'+  where+    exception =+      \case+        Text.DecodeError message byte -> fromString message+        _ -> $bug "Unexpected unicode exception"++-- |+-- Any of the variable-length character types:+-- BPCHAR, VARCHAR, NAME and TEXT.+{-# INLINABLE text_lazy #-}+text_lazy :: Decoder LazyText+text_lazy =+  bytea_lazy >>= either (failure . exception) return . LazyText.decodeUtf8'+  where+    exception =+      \case+        Text.DecodeError message byte -> fromString message+        _ -> $bug "Unexpected unicode exception"++-- |+-- BYTEA or any other type in its undecoded form.+{-# INLINE bytea_strict #-}+bytea_strict :: Decoder ByteString+bytea_strict =+  remainders++-- |+-- BYTEA or any other type in its undecoded form.+{-# INLINE bytea_lazy #-}+bytea_lazy :: Decoder LazyByteString+bytea_lazy =+  fmap LazyByteString.fromStrict remainders+++-- * Date and Time+-------------------------++-- |+-- @DATE@ values decoding.+date :: Decoder Day+date =+  fmap (Time.postgresJulianToDay . fromIntegral) (int :: Decoder Int32)++-- |+-- @TIME@ values decoding for servers, which have @integer_datetimes@ enabled.+time_int :: Decoder TimeOfDay+time_int =+  fmap Time.microsToTimeOfDay int++-- |+-- @TIME@ values decoding for servers, which don't have @integer_datetimes@ enabled.+time_float :: Decoder TimeOfDay+time_float =+  fmap Time.secsToTimeOfDay float8++-- |+-- @TIMETZ@ values decoding for servers, which have @integer_datetimes@ enabled.+timetz_int :: Decoder (TimeOfDay, TimeZone)+timetz_int =+  (,) <$> sized 8 time_int <*> tz++-- |+-- @TIMETZ@ values decoding for servers, which don't have @integer_datetimes@ enabled.+timetz_float :: Decoder (TimeOfDay, TimeZone)+timetz_float =+  (,) <$> sized 8 time_float <*> tz++{-# INLINE tz #-}+tz :: Decoder TimeZone+tz =+  fmap (minutesToTimeZone . negate . (flip div 60) . fromIntegral) (int :: Decoder Int32)++-- |+-- @TIMESTAMP@ values decoding for servers, which have @integer_datetimes@ enabled.+timestamp_int :: Decoder LocalTime+timestamp_int =+  fmap Time.microsToLocalTime int++-- |+-- @TIMESTAMP@ values decoding for servers, which don't have @integer_datetimes@ enabled.+timestamp_float :: Decoder LocalTime+timestamp_float =+  fmap Time.secsToLocalTime float8++-- |+-- @TIMESTAMP@ values decoding for servers, which have @integer_datetimes@ enabled.+timestamptz_int :: Decoder UTCTime+timestamptz_int =+  fmap Time.microsToUTC int++-- |+-- @TIMESTAMP@ values decoding for servers, which don't have @integer_datetimes@ enabled.+timestamptz_float :: Decoder UTCTime+timestamptz_float =+  fmap Time.secsToUTC float8++-- |+-- @INTERVAL@ values decoding for servers, which don't have @integer_datetimes@ enabled.+interval_int :: Decoder DiffTime+interval_int =+  do+    u <- sized 8 int+    d <- sized 4 int+    m <- int+    return $ Interval.toDiffTime $ Interval.Interval u d m++-- |+-- @INTERVAL@ values decoding for servers, which have @integer_datetimes@ enabled.+interval_float :: Decoder DiffTime+interval_float =+  do+    u <- sized 8 (fmap (round . (*(10^6)) . toRational) float8)+    d <- sized 4 int+    m <- int+    return $ Interval.toDiffTime $ Interval.Interval u d m+++-- * Exotic+-------------------------++-- |+-- A lower-level array data parser,+-- which aggregates the intermediate data representation as per the Postgres format.+-- +-- Only use this if 'array' doesn't fit your case.+{-# INLINABLE arrayRep #-}+arrayRep :: Decoder Data.Array+arrayRep =+  do+    dimensionsAmount <- intOfSize 4+    nullsValue <- nulls+    oid <- intOfSize 4+    dimensions <- Vector.replicateM dimensionsAmount dimension+    let valuesAmount = (Vector.product . Vector.map fst) dimensions+    values <- Vector.replicateM (fromIntegral valuesAmount) content+    return (dimensions, values, nullsValue, oid)+  where+    dimension =+      (,) <$> intOfSize 4 <*> intOfSize 4+    nulls =+      intOfSize 4 >>= \(x :: Word32) -> case x of+        0 -> return False+        1 -> return True+        w -> failure $ "Invalid value: " <> (fromString . show) w++{-# INLINABLE compositeRep #-}+compositeRep :: Decoder Data.Composite+compositeRep =+  do+    componentsAmount <- intOfSize 4+    Vector.replicateM componentsAmount component+  where+    component =+      (,) <$> intOfSize 4 <*> content++-- |+-- A function for generic in place parsing of an HStore value.+-- +-- Accepts:+-- +-- * An implementation of the @replicateM@ function+-- (@Control.Monad.'Control.Monad.replicateM'@, @Data.Vector.'Data.Vector.replicateM'@),+-- which determines how to produce the final datastructure from the rows.+-- +-- * A decoder for keys.+-- +-- * A decoder for values.+-- +-- Here's how you can use it to produce a parser to list:+-- +-- @+-- hstoreAsList :: Decoder [ ( Text , Maybe Text ) ]+-- hstoreAsList =+--   hstore replicateM text text+-- @+-- +{-# INLINABLE hstore #-}+hstore :: ( forall m. Monad m => Int -> m ( k , Maybe v ) -> m r ) -> Decoder k -> Decoder v -> Decoder r+hstore replicateM keyContent valueContent =+  do+    componentsAmount <- intOfSize 4+    replicateM componentsAmount component+  where+    component =+      (,) <$> key <*> value+      where+        key =+          onContent keyContent >>= nonNull+        value =+          onContent valueContent++{-# INLINABLE hstoreRep #-}+hstoreRep :: Decoder Data.HStore+hstoreRep =+  do+    componentsAmount <- intOfSize 4+    Vector.replicateM componentsAmount component+  where+    component =+      (,) <$> key <*> content+      where+        key =+          intOfSize 4 >>= bytesOfSize+++-- * Composite+-------------------------++newtype CompositeDecoder a =+  CompositeDecoder ( Decoder a )+  deriving ( Functor , Applicative , Monad )++-- |+-- Unlift a 'CompositeDecoder' to a value 'Decoder'.+{-# INLINE composite #-}+composite :: CompositeDecoder a -> Decoder a+composite (CompositeDecoder decoder) =+  unitOfSize 4 *> decoder++-- |+-- Lift a value 'Decoder' into 'CompositeDecoder'.+{-# INLINE compositeValue #-}+compositeValue :: Decoder a -> CompositeDecoder ( Maybe a )+compositeValue =+  CompositeDecoder . onContent++-- |+-- Lift a non-nullable value 'Decoder' into 'CompositeDecoder'.+{-# INLINE compositeNonNullValue #-}+compositeNonNullValue :: Decoder a -> CompositeDecoder a+compositeNonNullValue =+  CompositeDecoder . join . fmap (maybe (failure "Unexpected NULL") return) . onContent+++-- * Array+-------------------------++-- |+-- An efficient generic array decoder,+-- which constructs the result value in place while parsing.+-- +-- Here's how you can use it to produce a specific array value decoder:+-- +-- @+-- x :: Decoder [ [ Text ] ]+-- x =+--   array (arrayDimension replicateM (fmap catMaybes (arrayDimension replicateM (arrayValue text))))+-- @+-- +newtype ArrayDecoder a =+  ArrayDecoder ( [ Word32 ] -> Decoder a )+  deriving ( Functor )++-- |+-- Unlift an 'ArrayDecoder' to a value 'Decoder'.+{-# INLINE array #-}+array :: ArrayDecoder a -> Decoder a+array (ArrayDecoder decoder) =+  do+    dimensionsAmount <- intOfSize 4+    unitOfSize (4 + 4)+    dimensionSizes <- replicateM dimensionsAmount dimensionSize+    decoder dimensionSizes+  where+    dimensionSize =+      intOfSize 4 <* unitOfSize 4++-- |+-- A function for parsing a dimension of an array.+-- Provides support for multi-dimensional arrays.+-- +-- Accepts:+-- +-- * An implementation of the @replicateM@ function+-- (@Control.Monad.'Control.Monad.replicateM'@, @Data.Vector.'Data.Vector.replicateM'@),+-- which determines the output value.+-- +-- * A decoder of its components, which can be either another 'arrayDimension' or 'arrayValue'.+-- +{-# INLINE arrayDimension #-}+arrayDimension :: ( forall m. Monad m => Int -> m a -> m b ) -> ArrayDecoder a -> ArrayDecoder b+arrayDimension replicateM (ArrayDecoder component) =+  ArrayDecoder $ \case+    head : tail -> replicateM (fromIntegral head) (component tail)+    _ -> failure "A missing dimension length"++-- |+-- Lift a value 'Decoder' into 'ArrayDecoder' for parsing of nullable leaf values.+{-# INLINE arrayValue #-}+arrayValue :: Decoder a -> ArrayDecoder ( Maybe a )+arrayValue =+  ArrayDecoder . const . onContent++-- |+-- Lift a value 'Decoder' into 'ArrayDecoder' for parsing of non-nullable leaf values.+{-# INLINE arrayNonNullValue #-}+arrayNonNullValue :: Decoder a -> ArrayDecoder a+arrayNonNullValue =+  ArrayDecoder . const . join . fmap (maybe (failure "Unexpected NULL") return) . onContent+++-- * Enum+-------------------------++-- |+-- Given a partial mapping from text to value,+-- produces a decoder of that value.+{-# INLINE enum #-}+enum :: (Text -> Maybe a) -> Decoder a+enum mapping =+  text_strict >>= onText+  where+    onText text =+      maybe onNothing onJust (mapping text)+      where+        onNothing =+          failure ("No mapping for text \"" <> text <> "\"")+        onJust =+          pure
+ library/PostgreSQL/Binary/Encoder.hs view
@@ -0,0 +1,502 @@+module PostgreSQL.Binary.Encoder+(+  run,+  -- * Value encoder+  Encoder,+  int2_int16,+  int2_word16,+  int4_int32,+  int4_word32,+  int8_int64,+  int8_word64,+  float4,+  float8,+  composite,+  bool,+  numeric,+  uuid,+  json,+  char,+  text_strict,+  text_lazy,+  bytea_strict,+  bytea_lazy,+  date,+  time_int,+  time_float,+  timetz_int,+  timetz_float,+  timestamp_int,+  timestamp_float,+  timestamptz_int,+  timestamptz_float,+  interval_int,+  interval_float,+  hstore,+  hstoreRep,+  array,+  -- * Array encoder+  ArrayEncoder,+  arrayValue,+  arrayNullableValue,+  arrayDimension,+  arrayRep,+  -- * Enum+  enum,+)+where++import PostgreSQL.Binary.Prelude hiding (take, bool, maybe)+import Data.ByteString.Builder (Builder)+import qualified Data.ByteString.Builder as Builder+import qualified Data.ByteString as ByteString+import qualified Data.ByteString.Lazy as LazyByteString+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import qualified Data.Text.Lazy as LazyText+import qualified Data.Text.Lazy.Encoding as LazyText+import qualified Data.Vector as Vector+import qualified Data.Scientific as Scientific+import qualified Data.Aeson as Aeson+import qualified Data.UUID as UUID+import qualified PostgreSQL.Binary.Data as Data+import qualified PostgreSQL.Binary.Integral as Integral+import qualified PostgreSQL.Binary.Numeric as Numeric+import qualified PostgreSQL.Binary.Time as Time+import qualified PostgreSQL.Binary.Interval as Interval+import qualified PostgreSQL.Binary.BuilderPrim as BuilderPrim+import qualified Control.Foldl as Foldl+++type Encoder a =+  a -> Builder++{-# INLINE run #-}+run :: Encoder a -> a -> ByteString+run encoder =+  LazyByteString.toStrict . Builder.toLazyByteString . encoder++{-# INLINE tuple2 #-}+tuple2 :: Encoder a -> Encoder b -> Encoder (a, b)+tuple2 e1 e2 =+  \(v1, v2) -> e1 v1 <> e2 v2++{-# INLINE tuple3 #-}+tuple3 :: Encoder a -> Encoder b -> Encoder c -> Encoder (a, b, c)+tuple3 e1 e2 e3 =+  \(v1, v2, v3) -> e1 v1 <> e2 v2 <> e3 v3++{-# INLINE tuple4 #-}+tuple4 :: Encoder a -> Encoder b -> Encoder c -> Encoder d -> Encoder (a, b, c, d)+tuple4 e1 e2 e3 e4 =+  \(v1, v2, v3, v4) -> e1 v1 <> e2 v2 <> e3 v3 <> e4 v4++{-# INLINE premap #-}+premap :: (a -> b) -> Encoder b -> Encoder a+premap f e =+  e . f++{-# INLINE int2_int16 #-}+int2_int16 :: Encoder Int16+int2_int16 =+  Builder.int16BE++{-# INLINE int2_word16 #-}+int2_word16 :: Encoder Word16+int2_word16 =+  Builder.word16BE++{-# INLINE int4_int32 #-}+int4_int32 :: Encoder Int32+int4_int32 =+  Builder.int32BE++{-# INLINE int4_word32 #-}+int4_word32 :: Encoder Word32+int4_word32 =+  Builder.word32BE++{-# INLINE int4_int #-}+int4_int :: Encoder Int+int4_int =+  int4_int32 . fromIntegral++{-# INLINE int8_int64 #-}+int8_int64 :: Encoder Int64+int8_int64 =+  Builder.int64BE++{-# INLINE int8_word64 #-}+int8_word64 :: Encoder Word64+int8_word64 =+  Builder.word64BE++{-# INLINE float4 #-}+float4 :: Encoder Float+float4 =+  int4_int32 . unsafeCoerce++{-# INLINE float8 #-}+float8 :: Encoder Double+float8 =+  int8_int64 . unsafeCoerce++{-# INLINE null4 #-}+null4 :: ByteStringBuilder+null4 =+  Builder.string7 "\255\255\255\255"++{-# INLINABLE composite #-}+composite :: Encoder Data.Composite+composite vector =+  int4_int (Vector.length vector) <>+  foldMap component vector+  where+    component (oid, theContent) =+      int4_word32 oid <> content theContent++{-# INLINABLE content #-}+content :: Encoder Data.Content+content =+  \case+    Nothing ->+      null4+    Just content ->+      int4_int (ByteString.length content) <>+      Builder.byteString content++{-# INLINABLE maybe #-}+maybe :: Encoder a -> Encoder (Maybe a)+maybe encoder =+  \case+    Nothing ->+      null4+    Just value ->+      run encoder value & \bytes -> int4_int (ByteString.length bytes) <> Builder.byteString bytes++{-# INLINE bool #-}+bool :: Encoder Bool+bool =+  \case+    True -> Builder.word8 1+    False -> Builder.word8 0++{-# INLINABLE numeric #-}+numeric :: Encoder Scientific+numeric x =+  int2_int16 (fromIntegral componentsAmount) <>+  int2_int16 (fromIntegral pointIndex) <>+  int2_word16 signCode <>+  int2_int16 (fromIntegral trimmedExponent) <>+  foldMap int2_int16 components+  where+    componentsAmount = +      length components+    coefficient =+      Scientific.coefficient x+    exponent = +      Scientific.base10Exponent x+    components = +      Numeric.extractComponents tunedCoefficient+    pointIndex =+      componentsAmount + (tunedExponent `div` 4) - 1+    (tunedCoefficient, tunedExponent) =+      case mod exponent 4 of+        0 -> (coefficient, exponent)+        x -> (coefficient * 10 ^ x, exponent - x)+    trimmedExponent =+      if tunedExponent >= 0+        then 0+        else negate tunedExponent+    signCode =+      if coefficient < 0+        then Numeric.negSignCode+        else Numeric.posSignCode++{-# INLINABLE uuid #-}+uuid :: Encoder UUID+uuid =+  premap UUID.toWords (tuple4 int4_word32 int4_word32 int4_word32 int4_word32)++{-# INLINABLE json #-}+json :: Encoder Aeson.Value+json =+  Aeson.fromEncoding . Aeson.toEncoding+++-- * Text+-------------------------++-- |+-- A UTF-8-encoded char.+-- +-- Note that since it's UTF-8-encoded+-- not the \"char\" but the \"text\" OID should be used with it.+{-# INLINABLE char #-}+char :: Encoder Char+char = +  Builder.charUtf8++{-# INLINABLE text_strict #-}+text_strict :: Encoder Text+text_strict =+  Text.encodeUtf8BuilderEscaped BuilderPrim.nullByteIgnoringBoundedPrim++{-# INLINABLE text_lazy #-}+text_lazy :: Encoder LazyText.Text+text_lazy =+  LazyText.encodeUtf8BuilderEscaped BuilderPrim.nullByteIgnoringBoundedPrim++{-# INLINABLE bytea_strict #-}+bytea_strict :: Encoder ByteString+bytea_strict =+  Builder.byteString+  +{-# INLINABLE bytea_lazy #-}+bytea_lazy :: Encoder LazyByteString.ByteString+bytea_lazy =+  Builder.lazyByteString++-- * Date and Time+-------------------------++{-# INLINABLE date #-}+date :: Encoder Day+date =+  int4_int32 . fromIntegral . Time.dayToPostgresJulian++{-# INLINABLE time_int #-}+time_int :: Encoder TimeOfDay+time_int (TimeOfDay h m s) =+  let+    p = unsafeCoerce s :: Integer+    u = p `div` (10^6)+    in int8_int64 (fromIntegral u + 10^6 * 60 * (fromIntegral m + 60 * fromIntegral h))++{-# INLINABLE time_float #-}+time_float :: Encoder TimeOfDay+time_float (TimeOfDay h m s) =+  let+    p = unsafeCoerce s :: Integer+    u = p `div` (10^6)+    in float8 (fromIntegral u / 10^6 + 60 * (fromIntegral m + 60 * (fromIntegral h)))++{-# INLINABLE timetz_int #-}+timetz_int :: Encoder (TimeOfDay, TimeZone)+timetz_int (timeX, tzX) =+  time_int timeX <> tz tzX++{-# INLINABLE timetz_float #-}+timetz_float :: Encoder (TimeOfDay, TimeZone)+timetz_float (timeX, tzX) =+  time_float timeX <> tz tzX++{-# INLINE tz #-}+tz :: Encoder TimeZone+tz =+  int4_int . (*60) . negate . timeZoneMinutes++{-# INLINABLE timestamp_int #-}+timestamp_int :: Encoder LocalTime+timestamp_int =+  int8_int64 . Time.localTimeToMicros++{-# INLINABLE timestamp_float #-}+timestamp_float :: Encoder LocalTime+timestamp_float =+  float8 . Time.localTimeToSecs++{-# INLINABLE timestamptz_int #-}+timestamptz_int :: Encoder UTCTime+timestamptz_int =+  int8_int64 . Time.utcToMicros++{-# INLINABLE timestamptz_float #-}+timestamptz_float :: Encoder UTCTime+timestamptz_float =+  float8 . Time.utcToSecs++{-# INLINABLE interval_int #-}+interval_int :: Encoder DiffTime+interval_int x =+    Builder.int64BE u <>+    Builder.int32BE d <>+    Builder.int32BE m+  where+    Interval.Interval u d m = +      fromMaybe (error ("Too large DiffTime value for an interval " <> show x)) $+      Interval.fromDiffTime x++{-# INLINABLE interval_float #-}+interval_float :: Encoder DiffTime+interval_float x =+    Builder.doubleBE s <>+    Builder.int32BE d <>+    Builder.int32BE m+  where+    Interval.Interval u d m = +      fromMaybe (error ("Too large DiffTime value for an interval " <> show x)) $+      Interval.fromDiffTime x+    s =+      fromIntegral u / (10^6)+++-- * Array+-------------------------++newtype ArrayEncoder a =+  ArrayEncoder (a -> (Builder, [Int32], Bool))++{-# INLINABLE array #-}+array :: Word32 -> ArrayEncoder a -> Encoder a+array oid (ArrayEncoder encoder) =+  \value ->+    let+      (valuesBuilder, dimensions, nulls) =+        encoder value+      (dimensionsAmount, dimensionsBuilder) =+        let+          step (amount, builder) dimension =+            (succ amount, builder <> Builder.int32BE dimension <> Builder.word32BE 1)+          init =+            (0, mempty)+          in+            foldl' step init dimensions+      nullsBuilder =+        Builder.word32BE (if nulls then 1 else 0)+      in+        Builder.word32BE dimensionsAmount <> nullsBuilder <> Builder.word32BE oid <> dimensionsBuilder <> valuesBuilder++{-# INLINABLE arrayValue #-}+arrayValue :: Encoder a -> ArrayEncoder a+arrayValue encoder =+  ArrayEncoder $ \value ->+    let+      bytes =+        run encoder value+      builder =+        Builder.word32BE (fromIntegral (ByteString.length bytes)) <>+        Builder.byteString bytes+      in+        (builder, [], False)++{-# INLINABLE arrayNullableValue #-}+arrayNullableValue :: Encoder a -> ArrayEncoder (Maybe a)+arrayNullableValue encoder =+  ArrayEncoder $ \case+    Nothing ->+      (int4_int32 (-1), [], True)+    Just value ->+      let+        bytes =+          run encoder value+        builder =+          Builder.word32BE (fromIntegral (ByteString.length bytes)) <>+          Builder.byteString bytes+        in+          (builder, [], False)++{-# INLINABLE arrayDimension #-}+arrayDimension :: (forall a. (a -> b -> a) -> a -> c -> a) -> ArrayEncoder b -> ArrayEncoder c+arrayDimension foldl (ArrayEncoder encoder) =+  ArrayEncoder $ \value ->+    let+      step (builder, _, length, nulls) value =+        let+          (valueBuilder, valueDimensions, valueNulls) = encoder value+          in+            (builder <> valueBuilder, valueDimensions, succ length, nulls || valueNulls)+      init =+        (mempty, [], 0, False)+      (foldedBuilder, foldedDimensions, foldedLength, foldedNulls) =+        foldl step init value+      resultDimensions =+        foldedLength : foldedDimensions+      in+        (foldedBuilder, resultDimensions, foldedNulls)+        ++-- * Array rep+-------------------------++{-# INLINABLE arrayRep #-}+arrayRep :: Encoder Data.Array+arrayRep (dimensionsV, valuesV, nullsV, oidV) =+  dimensionsLength <> nulls <> oid <> dimensions <> values+  where+    dimensionsLength = +      int4_word32 $ fromIntegral $ length dimensionsV+    nulls = +      int4_word32 $ if nullsV then 1 else 0+    oid = +      int4_word32 oidV+    dimensions = +      foldMap dimension dimensionsV+    values = +      foldMap value valuesV+    dimension (w, l) = +      int4_word32 w <> int4_word32 l+    value =+      \case+        Nothing -> int4_int32 (-1)+        Just b -> int4_int32 (fromIntegral (ByteString.length b)) <> Builder.byteString b+++-- * HStore+-------------------------++-- |+-- A polymorphic in-place @HSTORE@ encoder.+-- +-- Accepts:+-- +-- * An implementation of the @foldl@ function+-- (e.g., @Data.Foldable.'foldl''@),+-- which determines the input value.+-- +-- Here's how you can use it to produce a specific encoder:+-- +-- @+-- hashMapHStore :: Encoder (Data.HashMap.Strict.HashMap Text (Maybe Text))+-- hashMapHStore =+--   hstore foldl'+-- @+-- +{-# INLINABLE hstore #-}+hstore :: (forall a. (a -> (Text, Maybe Text) -> a) -> a -> b -> a) -> Encoder b+hstore foldl =+  fold & \(Foldl.Fold step init fin) -> fin . foldl step init+  where+    fold =+      (<>) <$> componentsAmount <*> components+      where+        componentsAmount =+          fmap int4_int Foldl.length+        components =+          Foldl.foldMap componentBuilder id+          where+            componentBuilder (key, value) =+              text_strict key <> maybe text_strict value++{-# INLINABLE hstoreRep #-}+hstoreRep :: Encoder Data.HStore+hstoreRep vector =+  int4_int32 (fromIntegral (Vector.length vector)) <>+  foldMap component vector+  where+    component (key, value) =+      Builder.byteString key <> content value+++-- * Enum+-------------------------++-- |+-- Given a function,+-- which maps the value into the textual enum label from the DB side,+-- produces an encoder of that value+-- +{-# INLINE enum #-}+enum :: (a -> Text) -> Encoder a+enum asText =+  text_strict . asText
+ library/PostgreSQL/Binary/Integral.hs view
@@ -0,0 +1,20 @@+-- |+-- Utils for dealing with integer numbers.+module PostgreSQL.Binary.Integral where++import PostgreSQL.Binary.Prelude+import qualified Data.ByteString as B+++{-# INLINABLE pack #-}+pack :: (Bits a, Num a) => B.ByteString -> a+pack =+  B.foldl' (\n h -> shiftL n 8 .|. fromIntegral h) 0++{-# INLINE unpackBySize #-}+unpackBySize :: (Bits a, Integral a) => Int -> a -> B.ByteString+unpackBySize n x =+  B.pack $ map f $ reverse [0..n - 1]+  where +    f s =+      fromIntegral $ shiftR x (8 * s)
+ library/PostgreSQL/Binary/Interval.hs view
@@ -0,0 +1,43 @@+module PostgreSQL.Binary.Interval where++import PostgreSQL.Binary.Prelude hiding (months)+import qualified PostgreSQL.Binary.Time as Time+++data Interval = +  Interval {+    micros :: Int64,+    days :: Int32,+    months :: Int32+  } +  deriving (Show, Eq)+++-- |+-- Oddly enough despite a claim of support of up to 178000000 years in+-- <http://www.postgresql.org/docs/9.3/static/datatype-datetime.html Postgres' docs>+-- in practice it starts behaving unpredictably after a smaller limit.+maxDiffTime :: DiffTime = 1780000 * Time.microsToDiffTime Time.yearMicros+minDiffTime :: DiffTime = negate maxDiffTime++fromDiffTime :: DiffTime -> Maybe Interval+fromDiffTime x =+  if x > maxDiffTime || x < minDiffTime+    then Nothing+    else Just $ fromPicosUnsafe (unsafeCoerce x)++fromPicosUnsafe :: Integer -> Interval+fromPicosUnsafe =+  evalState $ do+    modify $ flip div (10^6)+    u <- state $ swap . flip divMod (10 ^ 6 * 60 * 60 * 24)+    d <- state $ swap . flip divMod (31)+    m <- get+    return $ Interval (fromIntegral u) (fromIntegral d) (fromIntegral m)++toDiffTime :: Interval -> DiffTime+toDiffTime x =+  picosecondsToDiffTime $ +    (10 ^ 6) *+    (fromIntegral (micros x) + +     10 ^ 6 * 60 * 60 * 24 * (fromIntegral (days x + 31 * months x)))
+ library/PostgreSQL/Binary/Numeric.hs view
@@ -0,0 +1,77 @@+module PostgreSQL.Binary.Numeric where++import PostgreSQL.Binary.Prelude+import qualified Data.Vector as Vector+import qualified Data.Scientific as Scientific+++{-# INLINE posSignCode #-}+posSignCode :: Word16+posSignCode = 0x0000++{-# INLINE negSignCode #-}+negSignCode :: Word16+negSignCode = 0x4000++{-# INLINE nanSignCode #-}+nanSignCode :: Word16+nanSignCode = 0xC000++{-# INLINE extractComponents #-}+extractComponents :: Integral a => a -> [Int16]+extractComponents =+  (reverse .) . (. abs) . unfoldr $ \case+    0 -> Nothing+    x -> case divMod x 10000 of+      (d, m) -> Just (fromIntegral m, d)++{-# INLINE mergeComponents #-}+mergeComponents :: Integral a => Vector a -> Integer+mergeComponents = +  Vector.foldl' (\l r -> l * 10000 + fromIntegral r) 0++{-# INLINE mergeDigits #-}+mergeDigits :: Integral a => Vector a -> a+mergeDigits = +  Vector.foldl' (\l r -> l * 10 + r) 0++-- |+-- Unpack a component into digits.+{-# INLINE componentDigits #-}+componentDigits :: Int16 -> [Int16]+componentDigits =+  evalState $ do+    a <- state (flip divMod 1000)+    b <- state (flip divMod 100)+    c <- state (flip divMod 10)+    d <- get+    return $ [a, b, c, d]++{-# INLINABLE componentsReplicateM #-}+componentsReplicateM :: (Integral a, Applicative m) => Int -> m a -> m a+componentsReplicateM amount component = +  foldl' folder (pure 0) (replicate amount component)+  where+    folder acc component =+      liftA2 (+) (fmap (*10000) acc) component++{-# INLINE signer #-}+signer :: Integral a => Word16 -> Either Text (a -> a)+signer =+  \case+    0x0000 -> return id+    0x4000 -> return negate+    0xC000 -> Left "NAN sign"+    signCode -> Left ("Unexpected sign code: " <> (fromString . show) signCode)++{-# INLINE scientific #-}+scientific :: Int16 -> Word16 -> Vector Word16 -> Either Text Scientific+scientific pointIndex signCode components =+  do+    theSigner <- signer signCode+    return (Scientific.scientific (c theSigner) e)+  where+    c signer =+      signer (mergeComponents components)+    e =+      (fromIntegral pointIndex + 1 - Vector.length components) * 4
+ library/PostgreSQL/Binary/Prelude.hs view
@@ -0,0 +1,94 @@+module PostgreSQL.Binary.Prelude+( +  module Exports,+  LazyByteString,+  ByteStringBuilder,+  LazyText,+  TextBuilder,+  bug,+  bottom,+  mapLeft,+  joinMap,+)+where+++-- base-prelude+-------------------------+import BasePrelude as Exports hiding (assert, Data, fail)++-- transformers+-------------------------+import Control.Monad.Trans.State.Strict as Exports hiding (liftCallCC, liftCatch)+import Control.Monad.Trans.Reader as Exports hiding (liftCallCC, liftCatch)+import Control.Monad.Trans.Class as Exports+import Data.Functor.Identity as Exports++-- bytestring+-------------------------+import Data.ByteString as Exports (ByteString)++-- text+-------------------------+import Data.Text as Exports (Text)++-- vector+-------------------------+import Data.Vector as Exports (Vector)++-- scientific+-------------------------+import Data.Scientific as Exports (Scientific)++-- uuid+-------------------------+import Data.UUID as Exports (UUID)++-- time+-------------------------+import Data.Time as Exports++-- placeholders+-------------------------+import Development.Placeholders as Exports++-- loch-th+-------------------------+import Debug.Trace.LocationTH as Exports++-- custom+-------------------------+import qualified Data.ByteString.Lazy+import qualified Data.ByteString.Builder+import qualified Data.Text.Lazy+import qualified Data.Text.Lazy.Builder+import qualified Debug.Trace.LocationTH+++type LazyByteString =+  Data.ByteString.Lazy.ByteString++type ByteStringBuilder =+  Data.ByteString.Builder.Builder++type LazyText =+  Data.Text.Lazy.Text++type TextBuilder =+  Data.Text.Lazy.Builder.Builder+++bug = [e| $(Debug.Trace.LocationTH.failure) . (msg <>) |]+  where+    msg = "A \"postgresql-binary\" package bug: " :: String++bottom = [e| $bug "Bottom evaluated" |]++{-# INLINE mapLeft #-}+mapLeft :: (a -> b) -> Either a x -> Either b x+mapLeft f =+  either (Left . f) Right++joinMap :: Monad m => (a -> m b) -> m a -> m b+joinMap f =+  join . fmap f
+ library/PostgreSQL/Binary/Time.hs view
@@ -0,0 +1,134 @@+module PostgreSQL.Binary.Time where++import PostgreSQL.Binary.Prelude hiding (second)+import Data.Time.Calendar.Julian+++{-# INLINABLE dayToPostgresJulian #-}+dayToPostgresJulian :: Day -> Integer+dayToPostgresJulian =+  (+ (2400001 - 2451545)) . toModifiedJulianDay++{-# INLINABLE postgresJulianToDay #-}+postgresJulianToDay :: Integral a => a -> Day+postgresJulianToDay =+  ModifiedJulianDay . fromIntegral . subtract (2400001 - 2451545)++{-# INLINABLE microsToTimeOfDay #-}+microsToTimeOfDay :: Int64 -> TimeOfDay+microsToTimeOfDay =+  evalState $ do+    h <- state $ flip divMod $ 10 ^ 6 * 60 * 60+    m <- state $ flip divMod $ 10 ^ 6 * 60+    u <- get+    return $+      TimeOfDay (fromIntegral h) (fromIntegral m) (microsToPico u)++{-# INLINABLE microsToUTC #-}+microsToUTC :: Int64 -> UTCTime+microsToUTC =+  evalState $ do+    d <- state $ flip divMod $ 10^6 * 60 * 60 * 24+    u <- get+    return $+      UTCTime (postgresJulianToDay d) (microsToDiffTime u)++{-# INLINABLE microsToPico #-}+microsToPico :: Int64 -> Pico+microsToPico =+  unsafeCoerce . (* (10^6)) . (fromIntegral :: Int64 -> Integer)++{-# INLINABLE microsToDiffTime #-}+microsToDiffTime :: Int64 -> DiffTime+microsToDiffTime =+  unsafeCoerce microsToPico++{-# INLINABLE microsToLocalTime #-}+microsToLocalTime :: Int64 -> LocalTime+microsToLocalTime =+  evalState $ do+    d <- state $ flip divMod $ 10^6 * 60 * 60 * 24+    u <- get+    return $+      LocalTime (postgresJulianToDay d) (microsToTimeOfDay u)++{-# INLINABLE secsToTimeOfDay #-}+secsToTimeOfDay :: Double -> TimeOfDay+secsToTimeOfDay =+  evalState $ do+    h <- state $ flip divMod' $ 60 * 60+    m <- state $ flip divMod' $ 60+    s <- get+    return $+      TimeOfDay (fromIntegral h) (fromIntegral m) (secsToPico s)++{-# INLINABLE secsToUTC #-}+secsToUTC :: Double -> UTCTime+secsToUTC =+  evalState $ do+    d <- state $ flip divMod' $ 60 * 60 * 24+    s <- get+    return $+      UTCTime (postgresJulianToDay d) (secsToDiffTime s)++{-# INLINABLE secsToLocalTime #-}+secsToLocalTime :: Double -> LocalTime+secsToLocalTime =+  evalState $ do+    d <- state $ flip divMod' $ 60 * 60 * 24+    s <- get+    return $+      LocalTime (postgresJulianToDay d) (secsToTimeOfDay s)++{-# INLINABLE secsToPico #-}+secsToPico :: Double -> Pico+secsToPico s =+  unsafeCoerce (truncate $ toRational s * 10 ^ 12 :: Integer)++{-# INLINABLE secsToDiffTime #-}+secsToDiffTime :: Double -> DiffTime+secsToDiffTime =+  unsafeCoerce secsToPico++{-# INLINABLE localTimeToMicros #-}+localTimeToMicros :: LocalTime -> Int64+localTimeToMicros (LocalTime dayX timeX) =+  let d = dayToPostgresJulian dayX+      p = unsafeCoerce $ timeOfDayToTime timeX+      in 10^6 * 60 * 60 * 24 * fromIntegral d + fromIntegral (div p (10^6))++{-# INLINABLE localTimeToSecs #-}+localTimeToSecs :: LocalTime -> Double+localTimeToSecs (LocalTime dayX timeX) =+  let d = dayToPostgresJulian dayX+      p = unsafeCoerce $ timeOfDayToTime timeX+      in 60 * 60 * 24 * fromIntegral d + fromRational (p % (10^12))++{-# INLINABLE utcToMicros #-}+utcToMicros :: UTCTime -> Int64+utcToMicros (UTCTime dayX diffTimeX) =+  let d = dayToPostgresJulian dayX+      p = unsafeCoerce diffTimeX+      in 10^6 * 60 * 60 * 24 * fromIntegral d + fromIntegral (div p (10^6))++{-# INLINABLE utcToSecs #-}+utcToSecs :: UTCTime -> Double+utcToSecs (UTCTime dayX diffTimeX) =+  let d = dayToPostgresJulian dayX+      p = unsafeCoerce diffTimeX+      in 60 * 60 * 24 * fromIntegral d + fromRational (p % (10^12))+++-- * Constants in microseconds according to Julian dates standard+-------------------------+-- According to+-- http://www.postgresql.org/docs/9.1/static/datatype-datetime.html+-- Postgres uses Julian dates internally+-------------------------++yearMicros   :: Int64 = truncate (365.2425 * fromIntegral dayMicros :: Rational)+dayMicros    :: Int64 = 24 * hourMicros+hourMicros   :: Int64 = 60 * minuteMicros+minuteMicros :: Int64 = 60 * secondMicros+secondMicros :: Int64 = 10 ^ 6 +
− library/PostgreSQLBinary/Array.hs 
@@ -1,73 +0,0 @@--- |--- An intermediate array representation--- and utilities for its (de)composition.-module PostgreSQLBinary.Array where--import PostgreSQLBinary.Prelude hiding (Data)----- | --- A representation of a data serializable to the PostgreSQL array binary format.--- --- Consists of a list of dimensions, a list of encoded elements,--- a flag specifying, whether it contains any nulls, and an oid.-type Data = ([Dimension], [Value], Bool, Word32)---- | --- A width and a lower bound.--- --- Currently the lower bound is only allowed to have a value of @1@.-type Dimension = (Word32, Word32)---- |--- An encoded value. 'Nothing' if it represents a @NULL@.-type Value = Maybe ByteString---- |--- Access a value of data, if the data represents a single value.-asSingleton :: Data -> Maybe Value-asSingleton (dimensions, elements, nulls, oid) =-  if null dimensions-    then case elements of-      [x] -> return x-      l -> $bug $ "Unexpected amount of elements: " <> show l-    else mzero---- |--- Construct from a non-empty list,--- taking the shared parameters from the first element.-fromListUnsafe :: [Data] -> Data-fromListUnsafe list =-  case list of-    (dimensions, values, nulls, oid) : tail ->-      ((fromIntegral $ length list, 1) : dimensions, values <> foldMap valuesOf tail, nulls, oid)-      where-        valuesOf (_, x, _, _) = x-    _ ->-      error "Empty list"--fromSingleton :: Value -> Bool -> Word32 -> Data-fromSingleton value nullable oid =-  ([], [value], nullable, oid)---- |--- Get a list of elements.-elements :: Data -> [Data]-elements (dimensions, values, nulls, oid) =-  do-    subvalues <- slice values-    return (subdimensions, subvalues, nulls, oid)-  where-    ((width, lowerBound), subdimensions) =-      case dimensions of-        h : t -> (h, t)-        _ -> ((0, 1), [])-    chunkSize =-      if null subdimensions-        then 1-        else product $ map dimensionWidth $ subdimensions-      where-        dimensionWidth (x, _) = fromIntegral x-    slice = -      foldr (\f g l -> case f l of (a, b) -> a : g b) (const mzero) $ -      replicate (fromIntegral width) (splitAt chunkSize)
− library/PostgreSQLBinary/Decoder.hs 
@@ -1,175 +0,0 @@-module PostgreSQLBinary.Decoder where--import PostgreSQLBinary.Prelude hiding (bool)-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy.Builder as BB-import qualified Data.ByteString.Lazy as BL-import qualified Data.Text as T-import qualified Data.Text.Encoding as TE-import qualified Data.Text.Lazy as TL-import qualified Data.Text.Lazy.Encoding as TLE-import qualified Data.Scientific as Scientific-import qualified Data.UUID as UUID-import qualified PostgreSQLBinary.Decoder.Zepto as Zepto-import qualified PostgreSQLBinary.Array as Array-import qualified PostgreSQLBinary.Time as Time-import qualified PostgreSQLBinary.Integral as Integral-import qualified PostgreSQLBinary.Numeric as Numeric-import qualified PostgreSQLBinary.Interval as Interval----- |--- A function for decoding a byte string into a value.-type D a = ByteString -> Either Text a----- * Numbers------------------------------ |--- Any of PostgreSQL integer types.-{-# INLINABLE int #-}-int :: (Integral a, Bits a) => D a-int =-  Right . Integral.pack--{-# INLINABLE float4 #-}-float4 :: D Float-float4 =-  unsafeCoerce (int :: D Word32)--{-# INLINABLE float8 #-}-float8 :: D Double-float8 =-  unsafeCoerce (int :: D Word64)--{-# INLINABLE numeric #-}-numeric :: D Scientific-numeric =-  flip Zepto.run (inline Zepto.numeric)----- * Text------------------------------ |--- A UTF-8-encoded char.-{-# INLINABLE char #-}-char :: D Char-char x =-  maybe (Left "Empty input") (return . fst) . T.uncons =<< text x---- |--- Any of the variable-length character types:--- BPCHAR, VARCHAR, NAME and TEXT.-{-# INLINABLE text #-}-text :: D Text-text =-  either (Left . fromString . show) Right . TE.decodeUtf8'--{-# INLINE bytea #-}-bytea :: D ByteString-bytea =-  Right---- * Date and Time----------------------------{-# INLINABLE date #-}-date :: D Day-date =-  fmap (Time.postgresJulianToDay . fromIntegral) . (int :: D Int32)---- |--- The decoding strategy depends on whether the server supports @integer_datetimes@.-{-# INLINABLE time #-}-time :: Bool -> D TimeOfDay-time =-  \case-    True ->-      fmap Time.microsToTimeOfDay . int-    False ->-      fmap Time.secsToTimeOfDay . float8---- |--- The decoding strategy depends on whether the server supports @integer_datetimes@.-{-# INLINABLE timetz #-}-timetz :: Bool -> D (TimeOfDay, TimeZone)-timetz integer_datetimes =-  \x -> -    let (timeX, zoneX) = B.splitAt 8 x-        in (,) <$> time integer_datetimes timeX <*> tz zoneX-  where-    tz =-      fmap (minutesToTimeZone . negate . (`div` 60) . fromIntegral) . (int :: D Int32)---- |--- The decoding strategy depends on whether the server supports @integer_datetimes@.-{-# INLINABLE timestamptz #-}-timestamp :: Bool -> D LocalTime-timestamp =-  \case-    True ->-      fmap Time.microsToLocalTime . int-    False ->-      fmap Time.secsToLocalTime . float8---- |--- The decoding strategy depends on whether the server supports @integer_datetimes@.-{-# INLINABLE timestamp #-}-timestamptz :: Bool -> D UTCTime-timestamptz =-  \case-    True ->-      fmap Time.microsToUTC . int-    False ->-      fmap Time.secsToUTC . float8---- |--- The decoding strategy depends on whether the server supports @integer_datetimes@.-{-# INLINABLE interval #-}-interval :: Bool -> D DiffTime-interval integerDatetimes =-  evalState $ do-    t <- state $ B.splitAt 8-    d <- state $ B.splitAt 4-    m <- get-    return $ do-      ux <- if integerDatetimes-              then int t-              else float8 t >>= return . round . (* (10^6)) . toRational-      dx <- int d-      mx <- int m-      return $ Interval.toDiffTime $ Interval.Interval ux dx mx----- * Misc----------------------------{-# INLINABLE bool #-}-bool :: D Bool-bool b =-  case B.uncons b of-    Just (0, _) -> return False-    Just (1, _) -> return True-    _ -> Left ("Invalid value: " <> (fromString . show) b)--{-# INLINABLE uuid #-}-uuid :: D UUID-uuid =-  evalStateT $ -    UUID.fromWords <$> word <*> word <*> word <*> word-  where-    word = -      lift . int =<< state (B.splitAt 4)----- |--- Arbitrary array.--- --- Returns an intermediate representation,--- which can then be used to decode into a specific data type.-{-# INLINABLE array #-}-array :: D Array.Data-array =-  flip Zepto.run Zepto.array
− library/PostgreSQLBinary/Decoder/Zepto.hs 
@@ -1,71 +0,0 @@--- |--- Composable Attoparsec parsers.-module PostgreSQLBinary.Decoder.Zepto where--import PostgreSQLBinary.Prelude hiding (take, bool)-import Data.Attoparsec.Zepto-import qualified PostgreSQLBinary.Integral as Integral-import qualified PostgreSQLBinary.Array as Array-import qualified PostgreSQLBinary.Numeric as Numeric-import qualified Data.Scientific as Scientific---{-# INLINE run #-}-run :: ByteString -> Parser a -> Either Text a-run input parser =-  either (Left . fromString . show) Right $ parse parser input    --{-# INLINE endOfInput #-}-endOfInput :: Parser ()-endOfInput =-  atEnd >>= \case True -> return (); False -> fail "Not an end of input"--{-# INLINE intOfSize #-}-intOfSize :: (Integral a, Bits a) => Int -> Parser a-intOfSize x =-  Integral.pack <$> take x--{-# INLINABLE array #-}-array :: Parser Array.Data-array =-  do-    dimensionsAmountV <- intOfSize 4-    nullsV <- nulls-    oidV <- intOfSize 4-    dimensionsV <- replicateM dimensionsAmountV dimension-    valuesV <- many value-    return (dimensionsV, valuesV, nullsV, oidV)-  where-    dimension =-      (,) <$> intOfSize 4 <*> intOfSize 4-    value =-      nothing <|> just-      where-        nothing =-          string (Integral.unpack (-1 :: Word32)) *> pure Nothing-        just =-          Just <$> (take =<< intOfSize 4)-    nulls =-      (intOfSize 4 :: Parser Word32) >>= \case-        0 -> return False-        1 -> return True-        w -> fail $ "Invalid value: " <> show w--{-# INLINE numeric #-}-numeric :: Parser Scientific-numeric =-  do-    componentsAmount <- intOfSize 2-    pointIndex :: Int16 <- intOfSize 2-    signCode <- intOfSize 2-    take 2-    components <- replicateM componentsAmount (intOfSize 2)-    signer <--      if | signCode == Numeric.negSignCode -> return negate-         | signCode == Numeric.posSignCode -> return id-         | signCode == Numeric.nanSignCode -> fail "NAN sign"-         | otherwise -> fail $ "Unexpected sign value: " <> show signCode-    let-      c = signer $ fromIntegral $ (Numeric.mergeComponents components :: Word64)-      e = (fromIntegral (pointIndex + 1) - length components) * 4-      in return $ Scientific.scientific c e
− library/PostgreSQLBinary/Encoder.hs 
@@ -1,174 +0,0 @@-module PostgreSQLBinary.Encoder where--import PostgreSQLBinary.Prelude-import qualified Data.ByteString as B-import qualified Data.ByteString.Char8 as BC-import qualified Data.ByteString.Lazy.Builder as BB-import qualified Data.ByteString.Lazy as BL-import qualified Data.ByteString.Lazy.Char8 as BLC-import qualified Data.Text as T-import qualified Data.Text.Encoding as TE-import qualified Data.Text.Lazy as TL-import qualified Data.Text.Lazy.Encoding as TLE-import qualified PostgreSQLBinary.Encoder.Builder as Builder-import qualified PostgreSQLBinary.Array as Array-import qualified PostgreSQLBinary.Time as Time-import qualified PostgreSQLBinary.Integral as Integral-import qualified PostgreSQLBinary.Interval as Interval-import qualified PostgreSQLBinary.Numeric as Numeric----- |--- A function for rendering a value into a byte string.-type E a = a -> ByteString----- * Numbers----------------------------{-# INLINABLE int2 #-}-int2 :: E (Either Int16 Word16)-int2 = -  either unpack unpack-  where-    unpack = Integral.unpackBySize 2--{-# INLINABLE int4 #-}-int4 :: E (Either Int32 Word32)-int4 = -  either unpack unpack-  where-    unpack = Integral.unpackBySize 4--{-# INLINABLE int8 #-}-int8 :: E (Either Int64 Word64)-int8 = -  either unpack unpack-  where-    unpack = Integral.unpackBySize 8--{-# INLINABLE float4 #-}-float4 :: E Float-float4 =-  int4 . Right . (unsafeCoerce :: Float -> Word32)--{-# INLINABLE float8 #-}-float8 :: E Double-float8 =-  int8 . Right . (unsafeCoerce :: Double -> Word64)--{-# INLINABLE numeric #-}-numeric :: E Scientific-numeric =-  Builder.run . Builder.numeric---- * Text------------------------------ |--- A UTF-8-encoded char.--- --- Note that since it's UTF-8-encoded--- not a \"char\" but a \"text\" OID should be used with it.-{-# INLINABLE char #-}-char :: E Char-char = -  text . Left . T.singleton---- |--- Either a strict or a lazy text.-{-# INLINABLE text #-}-text :: E (Either Text TL.Text)-text =-  either strict lazy-  where-    strict = TE.encodeUtf8 . T.filter (/= '\0')-    lazy = BL.toStrict . TLE.encodeUtf8 . TL.filter (/= '\0')---- |--- Either a strict or a lazy bytestring.-{-# INLINABLE bytea #-}-bytea :: E (Either ByteString BL.ByteString)-bytea =-  either id BL.toStrict---- * Date and Time----------------------------{-# INLINABLE date #-}-date :: E Day-date =-  Builder.run . Builder.date---- |--- Encoding strategy depends on whether the server supports @integer_datetimes@.-{-# INLINABLE time #-}-time :: Bool -> E TimeOfDay-time integer_datetimes (TimeOfDay h m s) =-  let-    p = unsafeCoerce s :: Integer-    u = p `div` (10^6)-    in if integer_datetimes-      then-        Integral.unpackBySize 8 $-          fromIntegral u + 10^6 * 60 * (m + 60 * h)-      else-        inline float8 $-          fromIntegral u / 10^6 + 60 * (fromIntegral m + 60 * (fromIntegral h))---- |--- Encoding strategy depends on whether the server supports @integer_datetimes@.-{-# INLINABLE timetz #-}-timetz :: Bool -> E (TimeOfDay, TimeZone)-timetz integer_datetimes (timeX, tzX) =-  inline time integer_datetimes timeX <> tz tzX-  where-    tz =-      Integral.unpackBySize 4 . (*60) . negate . timeZoneMinutes--{-# INLINABLE timestamp #-}-timestamp :: Bool -> E LocalTime-timestamp =-  \case-    True -> int8 . Left . Time.localTimeToMicros-    False -> float8 . Time.localTimeToSecs--{-# INLINABLE timestamptz #-}-timestamptz :: Bool -> E UTCTime-timestamptz =-  \case-    True -> int8 . Left . Time.utcToMicros-    False -> float8 . Time.utcToSecs--{-# INLINABLE interval #-}-interval :: Bool -> E DiffTime-interval integerDatetimes x =-  Builder.run $ -    (if integerDatetimes then BB.int64BE u else BB.doubleBE s) <>-    BB.int32BE d <>-    BB.int32BE m-  where-    Interval.Interval u d m = -      fromMaybe (error "Too large DiffTime value for an interval") $-      Interval.fromDiffTime x-    s = fromIntegral u / (10^6)---- * Misc----------------------------{-# INLINABLE bool #-}-bool :: E Bool-bool =-  \case-    False -> B.singleton 0-    True  -> B.singleton 1--{-# INLINABLE uuid #-}-uuid :: E UUID-uuid =-  Builder.run . Builder.uuid--{-# INLINABLE array #-}-array :: E Array.Data-array = -  Builder.run . Builder.array
− library/PostgreSQLBinary/Encoder/Builder.hs 
@@ -1,98 +0,0 @@-module PostgreSQLBinary.Encoder.Builder where--import PostgreSQLBinary.Prelude hiding (bool)-import Data.ByteString.Lazy.Builder-import qualified Data.ByteString as B-import qualified Data.ByteString.Char8 as BC-import qualified Data.ByteString.Lazy as BL-import qualified Data.ByteString.Lazy.Char8 as BLC-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import qualified Data.Text.Lazy as TL-import qualified Data.Text.Lazy.Encoding as TL-import qualified Data.Scientific as Scientific-import qualified Data.UUID as UUID-import qualified PostgreSQLBinary.Array as Array-import qualified PostgreSQLBinary.Time as Time-import qualified PostgreSQLBinary.Numeric as Numeric-import qualified PostgreSQLBinary.Interval as Interval---{-# INLINE run #-}-run :: Builder -> B.ByteString-run = -  BL.toStrict . toLazyByteString--{-# INLINE bool #-}-bool :: Bool -> Builder-bool = -  \case True -> word8 1; False -> word8 0--{-# INLINE array #-}-array :: Array.Data -> Builder-array (dimensionsV, valuesV, nullsV, oidV) =-  dimensionsLength <> nulls <> oid <> dimensions <> values-  where-    dimensionsLength = -      word32BE $ fromIntegral $ length dimensionsV-    nulls = -      word32BE $ if nullsV then 1 else 0-    oid = -      word32BE oidV-    dimensions = -      foldMap dimension dimensionsV-    values = -      foldMap value valuesV-    dimension (w, l) = -      word32BE w <> word32BE l-    value =-      \case-        Nothing -> word32BE (-1)-        Just b -> word32BE (fromIntegral (B.length b)) <> byteString b--{-# INLINE date #-}-date :: Day -> Builder-date =-  int32BE . fromIntegral . Time.dayToPostgresJulian--{-# INLINE numeric #-}-numeric :: Scientific -> Builder-numeric x =-  int16BE (fromIntegral componentsAmount) <>-  int16BE (fromIntegral pointIndex) <>-  word16BE signCode <>-  int16BE (fromIntegral trimmedExponent) <>-  foldMap int16BE components-  where-    componentsAmount = -      length components-    coefficient =-      Scientific.coefficient x-    exponent = -      Scientific.base10Exponent x-    components = -      Numeric.extractComponents tunedCoefficient-    pointIndex =-      componentsAmount + (tunedExponent `div` 4) - 1-    (tunedCoefficient, tunedExponent) =-      case mod exponent 4 of-        0 -> (coefficient, exponent)-        x -> (coefficient * 10 ^ x, exponent - x)-    trimmedExponent =-      if tunedExponent >= 0-        then 0-        else negate tunedExponent-    signCode =-      if coefficient < 0-        then Numeric.negSignCode-        else Numeric.posSignCode--{-# INLINE uuid #-}-uuid :: UUID -> Builder-uuid =-  UUID.toWords >>> \(a, b, c, d) -> -    word32BE a <> -    word32BE b <> -    word32BE c <> -    word32BE d-
− library/PostgreSQLBinary/Integral.hs 
@@ -1,24 +0,0 @@--- |--- Utils for dealing with numbers.-module PostgreSQLBinary.Integral where--import PostgreSQLBinary.Prelude-import qualified Data.ByteString as B---{-# INLINE byteSize #-}-byteSize :: (Bits a) => a -> Int-byteSize = (`div` 8) . bitSize--{-# INLINE pack #-}-pack :: (Bits a, Num a) => B.ByteString -> a-pack = B.foldl' (\n h -> (n `shiftL` 8) .|. fromIntegral h) 0--{-# INLINE unpack #-}-unpack :: (Bits a, Integral a) => a -> B.ByteString-unpack x = unpackBySize (byteSize x) x--{-# INLINE unpackBySize #-}-unpackBySize :: (Bits a, Integral a) => Int -> a -> B.ByteString-unpackBySize n x = B.pack $ map f $ reverse [0..n - 1]-  where f s = fromIntegral $ shiftR x (8 * s)
− library/PostgreSQLBinary/Interval.hs 
@@ -1,43 +0,0 @@-module PostgreSQLBinary.Interval where--import PostgreSQLBinary.Prelude hiding (months)-import qualified PostgreSQLBinary.Time as Time---data Interval = -  Interval {-    micros :: Int64,-    days :: Int32,-    months :: Int32-  } -  deriving (Show, Eq)----- |--- Oddly enough despite a claim of support of up to 178000000 years in--- <http://www.postgresql.org/docs/9.3/static/datatype-datetime.html Postgres' docs>--- in practice it starts behaving unpredictably after a smaller limit.-maxDiffTime :: DiffTime = 1780000 * Time.microsToDiffTime Time.yearMicros-minDiffTime :: DiffTime = negate maxDiffTime--fromDiffTime :: DiffTime -> Maybe Interval-fromDiffTime x =-  if x > maxDiffTime || x < minDiffTime-    then Nothing-    else Just $ fromPicosUnsafe (unsafeCoerce x)--fromPicosUnsafe :: Integer -> Interval-fromPicosUnsafe =-  evalState $ do-    modify $ flip div (10^6)-    u <- state $ swap . flip divMod (10 ^ 6 * 60 * 60 * 24)-    d <- state $ swap . flip divMod (31)-    m <- get-    return $ Interval (fromIntegral u) (fromIntegral d) (fromIntegral m)--toDiffTime :: Interval -> DiffTime-toDiffTime x =-  picosecondsToDiffTime $ -    (10 ^ 6) *-    (fromIntegral (micros x) + -     10 ^ 6 * 60 * 60 * 24 * (fromIntegral (days x + 31 * months x)))
− library/PostgreSQLBinary/Numeric.hs 
@@ -1,38 +0,0 @@-module PostgreSQLBinary.Numeric where--import PostgreSQLBinary.Prelude---posSignCode :: Word16 = 0x0000-negSignCode :: Word16 = 0x4000-nanSignCode :: Word16 = 0xC000--{-# INLINE extractComponents #-}-extractComponents :: Integral a => a -> [Int16]-extractComponents =-  (reverse .) . (. abs) . unfoldr $ \case-    0 -> Nothing-    x -> case divMod x 10000 of-      (d, m) -> Just (fromIntegral m, d)--{-# INLINE mergeComponents #-}-mergeComponents :: Integral a => [a] -> a-mergeComponents = -  foldl' (\l r -> l * 10000 + r) 0--{-# INLINE mergeDigits #-}-mergeDigits :: Integral a => [a] -> a-mergeDigits = -  foldl' (\l r -> l * 10 + r) 0---- |--- Unpack a component into digits.-{-# INLINE componentDigits #-}-componentDigits :: Int16 -> [Int16]-componentDigits =-  evalState $ do-    a <- state (`divMod` 1000)-    b <- state (`divMod` 100)-    c <- state (`divMod` 10)-    d <- get-    return $ [a, b, c, d]
− library/PostgreSQLBinary/Prelude.hs 
@@ -1,65 +0,0 @@-module PostgreSQLBinary.Prelude-( -  module Exports,-  LazyByteString,-  LazyText,-  bug,-  bottom,-  partial,-)-where----- base-prelude---------------------------import BasePrelude as Exports---- transformers---------------------------import Control.Monad.Trans.State.Strict as Exports hiding (liftCallCC, liftCatch)-import Control.Monad.Trans.Reader as Exports hiding (liftCallCC, liftCatch)-import Control.Monad.Trans.Class as Exports---- text---------------------------import Data.Text as Exports (Text)---- bytestring---------------------------import Data.ByteString as Exports (ByteString)---- scientific---------------------------import Data.Scientific as Exports (Scientific)---- uuid---------------------------import Data.UUID as Exports (UUID)---- time---------------------------import Data.Time as Exports---- placeholders---------------------------import Development.Placeholders as Exports---- custom---------------------------import qualified Debug.Trace.LocationTH-import qualified Data.Text.Lazy-import qualified Data.ByteString.Lazy---type LazyByteString = Data.ByteString.Lazy.ByteString-type LazyText = Data.Text.Lazy.Text--bug = [e| $(Debug.Trace.LocationTH.failure) . (msg <>) |]-  where-    msg = "A \"postgresql-binary\" package bug: " :: String--bottom = [e| $bug "Bottom evaluated" |]--partial :: Alternative f => (a -> Bool) -> a -> f a-partial p x = -  if p x then pure x else empty
− library/PostgreSQLBinary/Time.hs 
@@ -1,134 +0,0 @@-module PostgreSQLBinary.Time where--import PostgreSQLBinary.Prelude hiding (second)-import Data.Time.Calendar.Julian---{-# INLINABLE dayToPostgresJulian #-}-dayToPostgresJulian :: Day -> Integer-dayToPostgresJulian =-  (+ (2400001 - 2451545)) . toModifiedJulianDay--{-# INLINABLE postgresJulianToDay #-}-postgresJulianToDay :: Int64 -> Day-postgresJulianToDay =-  ModifiedJulianDay . fromIntegral . subtract (2400001 - 2451545)--{-# INLINABLE microsToTimeOfDay #-}-microsToTimeOfDay :: Int64 -> TimeOfDay-microsToTimeOfDay =-  evalState $ do-    h <- state $ flip divMod $ 10 ^ 6 * 60 * 60-    m <- state $ flip divMod $ 10 ^ 6 * 60-    u <- get-    return $-      TimeOfDay (fromIntegral h) (fromIntegral m) (microsToPico u)--{-# INLINABLE microsToUTC #-}-microsToUTC :: Int64 -> UTCTime-microsToUTC =-  evalState $ do-    d <- state $ flip divMod $ 10^6 * 60 * 60 * 24-    u <- get-    return $-      UTCTime (postgresJulianToDay d) (microsToDiffTime u)--{-# INLINABLE microsToPico #-}-microsToPico :: Int64 -> Pico-microsToPico =-  unsafeCoerce . (* (10^6)) . (fromIntegral :: Int64 -> Integer)--{-# INLINABLE microsToDiffTime #-}-microsToDiffTime :: Int64 -> DiffTime-microsToDiffTime =-  unsafeCoerce microsToPico--{-# INLINABLE microsToLocalTime #-}-microsToLocalTime :: Int64 -> LocalTime-microsToLocalTime =-  evalState $ do-    d <- state $ flip divMod $ 10^6 * 60 * 60 * 24-    u <- get-    return $-      LocalTime (postgresJulianToDay d) (microsToTimeOfDay u)--{-# INLINABLE secsToTimeOfDay #-}-secsToTimeOfDay :: Double -> TimeOfDay-secsToTimeOfDay =-  evalState $ do-    h <- state $ flip divMod' $ 60 * 60-    m <- state $ flip divMod' $ 60-    s <- get-    return $-      TimeOfDay (fromIntegral h) (fromIntegral m) (secsToPico s)--{-# INLINABLE secsToUTC #-}-secsToUTC :: Double -> UTCTime-secsToUTC =-  evalState $ do-    d <- state $ flip divMod' $ 60 * 60 * 24-    s <- get-    return $-      UTCTime (postgresJulianToDay d) (secsToDiffTime s)--{-# INLINABLE secsToLocalTime #-}-secsToLocalTime :: Double -> LocalTime-secsToLocalTime =-  evalState $ do-    d <- state $ flip divMod' $ 60 * 60 * 24-    s <- get-    return $-      LocalTime (postgresJulianToDay d) (secsToTimeOfDay s)--{-# INLINABLE secsToPico #-}-secsToPico :: Double -> Pico-secsToPico s =-  unsafeCoerce (truncate $ toRational s * 10 ^ 12 :: Integer)--{-# INLINABLE secsToDiffTime #-}-secsToDiffTime :: Double -> DiffTime-secsToDiffTime =-  unsafeCoerce secsToPico--{-# INLINABLE localTimeToMicros #-}-localTimeToMicros :: LocalTime -> Int64-localTimeToMicros (LocalTime dayX timeX) =-  let d = dayToPostgresJulian dayX-      p = unsafeCoerce $ timeOfDayToTime timeX-      in 10^6 * 60 * 60 * 24 * fromIntegral d + fromIntegral (div p (10^6))--{-# INLINABLE localTimeToSecs #-}-localTimeToSecs :: LocalTime -> Double-localTimeToSecs (LocalTime dayX timeX) =-  let d = dayToPostgresJulian dayX-      p = unsafeCoerce $ timeOfDayToTime timeX-      in 60 * 60 * 24 * fromIntegral d + fromRational (p % (10^12))--{-# INLINABLE utcToMicros #-}-utcToMicros :: UTCTime -> Int64-utcToMicros (UTCTime dayX diffTimeX) =-  let d = dayToPostgresJulian dayX-      p = unsafeCoerce diffTimeX-      in 10^6 * 60 * 60 * 24 * fromIntegral d + fromIntegral (div p (10^6))--{-# INLINABLE utcToSecs #-}-utcToSecs :: UTCTime -> Double-utcToSecs (UTCTime dayX diffTimeX) =-  let d = dayToPostgresJulian dayX-      p = unsafeCoerce diffTimeX-      in 60 * 60 * 24 * fromIntegral d + fromRational (p % (10^12))----- * Constants in microseconds according to Julian dates standard----------------------------- According to--- http://www.postgresql.org/docs/9.1/static/datatype-datetime.html--- Postgres uses Julian dates internally----------------------------yearMicros   :: Int64 = truncate (365.2425 * fromIntegral dayMicros :: Rational)-dayMicros    :: Int64 = 24 * hourMicros-hourMicros   :: Int64 = 60 * minuteMicros-minuteMicros :: Int64 = 60 * secondMicros-secondMicros :: Int64 = 10 ^ 6 -
postgresql-binary.cabal view
@@ -1,14 +1,14 @@ name:   postgresql-binary version:-  0.5.2.1+  0.7.4 synopsis:   Encoders and decoders for the PostgreSQL's binary format description:   An API for dealing with PostgreSQL's binary data format.   .-  It can be used to implement high level APIs for Postgres.-  E.g., <http://hackage.haskell.org/package/hasql-postgres "hasql-postgres">+  It can be used to implement performant bindings to Postgres.+  E.g., <http://hackage.haskell.org/package/hasql "hasql">   is based on this library.   .   It supports all Postgres versions starting from 8.3 @@ -53,47 +53,54 @@   default-language:     Haskell2010   other-modules:-    PostgreSQLBinary.Prelude-    PostgreSQLBinary.Encoder.Builder-    PostgreSQLBinary.Decoder.Zepto-    PostgreSQLBinary.Integral-    PostgreSQLBinary.Numeric-    PostgreSQLBinary.Time-    PostgreSQLBinary.Interval+    PostgreSQL.Binary.Prelude+    PostgreSQL.Binary.Integral+    PostgreSQL.Binary.Interval+    PostgreSQL.Binary.Numeric+    PostgreSQL.Binary.Time+    PostgreSQL.Binary.BuilderPrim   exposed-modules:-    PostgreSQLBinary.Array-    PostgreSQLBinary.Encoder-    PostgreSQLBinary.Decoder+    PostgreSQL.Binary.Data+    PostgreSQL.Binary.Decoder+    PostgreSQL.Binary.Encoder   build-depends:-    -- parsers:-    attoparsec >= 0.10 && < 0.14,+    -- parsing:+    binary-parser >= 0.5 && < 0.6,     -- data:+    aeson >= 0.10 && < 0.11,     uuid == 1.3.*,     time >= 1.4 && < 1.6,     scientific >= 0.2 && < 0.4,-    text >= 1 && < 1.3,-    bytestring >= 0.10 && < 0.11,+    bytestring >= 0.10.4 && < 0.11,+    text >= 1 && < 2,+    vector >= 0.10 && < 0.12,     -- errors:     loch-th == 0.2.*,     placeholders == 0.1.*,     -- general:+    foldl >= 1.1.1 && < 2,     transformers >= 0.3 && < 0.5,-    base-prelude >= 0.1.3 && < 0.2+    base-prelude >= 0.1.19 && < 0.2,+    base >= 4.6 && < 5  -test-suite tests-  type:             +-- This test-suite must be executed in a single-thread.+test-suite tasty+  type:     exitcode-stdio-1.0-  hs-source-dirs:   -    executables-  main-is:          -    Tests.hs+  hs-source-dirs:+    tasty+  main-is:+    Main.hs   other-modules:-    PostgreSQLBinary.PTI-  ghc-options:-    -threaded-    "-with-rtsopts=-N"-    -funbox-strict-fields+    Main.TextEncoder +    Main.DB+    Main.Apx+    Main.IO+    Main.Gens+    Main.PTI+    Main.Properties+    Main.Prelude   default-extensions:     Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, ImpredicativeTypes, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples   default-language:@@ -101,28 +108,40 @@   build-depends:     -- testing:     postgresql-binary,-    HTF == 0.12.*,-    quickcheck-instances == 0.3.*,-    QuickCheck >= 2.7 && < 2.9,-    -- database:     postgresql-libpq == 0.9.*,+    tasty == 0.11.*,+    tasty-quickcheck == 0.8.*,+    tasty-smallcheck == 0.8.*,+    tasty-hunit == 0.9.*,+    quickcheck-instances >= 0.3.11 && < 0.4,+    QuickCheck >= 2.8.1 && < 2.9,     -- data:     uuid == 1.3.*,     time >= 1.4 && < 1.6,     scientific >= 0.2 && < 0.4,-    text >= 1 && < 1.3,-    bytestring >= 0.10 && < 0.11,+    bytestring >= 0.10.4 && < 0.11,+    text >= 1 && < 2,+    vector >= 0.10 && < 0.12,+    -- errors:+    loch-th == 0.2.*,+    placeholders == 0.1.*,     -- general:-    base-prelude >= 0.1.3 && < 0.2+    conversion == 1.*,+    conversion-bytestring == 1.*,+    conversion-text == 1.*,+    either == 4.*,+    transformers,+    base-prelude,+    base  -benchmark decoding+benchmark encoding   type:      exitcode-stdio-1.0   hs-source-dirs:-    executables+    encoding   main-is:-    Decoding.hs+    Main.hs   ghc-options:     -O2     -threaded@@ -137,23 +156,23 @@     -- benchmarking:     criterion >= 1.0 && < 1.2,     -- data:-    time >= 1.4 && < 1.6,-    scientific >= 0.2 && < 0.4,-    text >= 1 && < 1.3,-    bytestring >= 0.10 && < 0.11,+    time,+    scientific,+    text,+    bytestring,     -- general:     deepseq >= 1.3 && < 1.5,     mtl-prelude < 3,-    base-prelude >= 0.1.3 && < 0.2+    base-prelude  -benchmark encoding+benchmark decoding   type:      exitcode-stdio-1.0   hs-source-dirs:-    executables+    decoding   main-is:-    Encoding.hs+    Main.hs   ghc-options:     -O2     -threaded@@ -168,11 +187,11 @@     -- benchmarking:     criterion >= 1.0 && < 1.2,     -- data:-    time >= 1.4 && < 1.6,-    scientific >= 0.2 && < 0.4,-    text >= 1 && < 1.3,-    bytestring >= 0.10 && < 0.11,+    time,+    scientific,+    text,+    bytestring,     -- general:     deepseq >= 1.3 && < 1.5,     mtl-prelude < 3,-    base-prelude >= 0.1.3 && < 0.2+    base-prelude
+ tasty/Main.hs view
@@ -0,0 +1,214 @@+module Main where++import Main.Prelude hiding (assert, isRight, isLeft)+import Control.Monad.IO.Class+import Test.QuickCheck.Instances+import Test.Tasty+import qualified Test.Tasty.HUnit as HUnit+import qualified Test.Tasty.SmallCheck as SmallCheck+import qualified Test.Tasty.QuickCheck as QuickCheck+import qualified Test.QuickCheck as QuickCheck+import qualified PostgreSQL.Binary.Encoder as Encoder+import qualified PostgreSQL.Binary.Decoder as Decoder+import qualified Data.ByteString as ByteString+import qualified Main.DB as DB+import qualified Main.Gens as Gens+import qualified Main.Properties as Properties+import qualified Main.IO as IO+import qualified Main.PTI as PTI+import qualified Main.TextEncoder as TextEncoder +import Main.Apx (Apx(..))+++main =+  defaultMain (testGroup "" [binary, textual])++binary =+  testGroup "Binary format"+  [+    select "SELECT '1 year 2 months 3 days 4 hours 5 minutes 6 seconds 332211 microseconds' :: interval"+    (bool Decoder.interval_float Decoder.interval_int)+    (picosecondsToDiffTime (10^6 * (332211 + 10^6 * (6 + 60 * (5 + 60 * (4 + 24 * (3 + 31 * (2 + 12))))))))+    ,+    timeRoundtrip "interval" Gens.intervalDiffTime PTI.interval+    (bool Encoder.interval_float Encoder.interval_int)+    (bool Decoder.interval_float Decoder.interval_int)+    ,+    timeRoundtrip "timestamp" (fmap Apx Gens.auto) PTI.timestamp+    ((. unApx) . bool Encoder.timestamp_float Encoder.timestamp_int)+    (fmap Apx . bool Decoder.timestamp_float Decoder.timestamp_int)+    ,+    HUnit.testCase "timestamptz offset" $ do+      Right (textual, decoded) <-+        DB.session $ do+          integerDatetimes <- DB.integerDatetimes+          let encoder = bool Encoder.timestamptz_float Encoder.timestamptz_int integerDatetimes+              decoder = bool Decoder.timestamptz_float Decoder.timestamptz_int integerDatetimes+          DB.unit "DROP TABLE IF EXISTS a" []+          DB.unit "CREATE TABLE a (b TIMESTAMPTZ)" []+          DB.unit "set timezone to 'America/Los_Angeles'" []+          let p = (,,) (PTI.oidPQ (PTI.ptiOID PTI.timestamptz))+                       (Encoder.run encoder x) +                       (DB.Binary)+              x = read "2011-09-28 00:17:25"+          DB.unit "insert into a (b) values ($1)" [Just p]+          DB.unit "set timezone to 'Europe/Stockholm'" []+          textual <- DB.oneRow "SELECT * FROM a" [] DB.Text+          decoded <- fmap (Decoder.run decoder) (DB.oneRow "SELECT * FROM a" [] DB.Binary)+          return (textual, decoded)+      HUnit.assertEqual "" ("2011-09-28 02:17:25+02") textual+      HUnit.assertEqual "" (Right (read "2011-09-28 00:17:25")) decoded+    ,+    timeRoundtrip "timestamptz" (fmap Apx Gens.auto) PTI.timestamptz+    ((. unApx) . bool Encoder.timestamptz_float Encoder.timestamptz_int)+    (fmap Apx . bool Decoder.timestamptz_float Decoder.timestamptz_int)+    ,+    timeRoundtrip "timetz" (fmap Apx Gens.timetz) PTI.timetz+    ((. unApx) . bool Encoder.timetz_float Encoder.timetz_int)+    (fmap Apx . bool Decoder.timetz_float Decoder.timetz_int)+    ,+    timeRoundtrip "time" (fmap Apx Gens.auto) PTI.time+    ((. unApx) . bool Encoder.time_float Encoder.time_int)+    (fmap Apx . bool Decoder.time_float Decoder.time_int)+    ,+    stdRoundtrip "numeric" Gens.scientific PTI.numeric Encoder.numeric Decoder.numeric+    ,+    select "SELECT -1234560.789 :: numeric" (const Decoder.numeric) (read "-1234560.789")+    ,+    select "SELECT -0.0789 :: numeric" (const Decoder.numeric) (read "-0.0789")+    ,+    select "SELECT 10000 :: numeric" (const Decoder.numeric) (read "10000")+    ,+    stdRoundtrip "float4" Gens.auto PTI.float4 Encoder.float4 Decoder.float4+    ,+    stdRoundtrip "float8" Gens.auto PTI.float8 Encoder.float8 Decoder.float8+    ,+    stdRoundtrip "char" Gens.char PTI.text Encoder.char Decoder.char+    ,+    stdRoundtrip "text_strict" Gens.text PTI.text Encoder.text_strict Decoder.text_strict+    ,+    stdRoundtrip "text_lazy" (fmap convert Gens.text) PTI.text Encoder.text_lazy Decoder.text_lazy+    ,+    stdRoundtrip "bytea_strict" Gens.auto PTI.bytea Encoder.bytea_strict Decoder.bytea_strict+    ,+    stdRoundtrip "bytea_lazy" Gens.auto PTI.bytea Encoder.bytea_lazy Decoder.bytea_lazy+    ,+    stdRoundtrip "uuid" Gens.uuid PTI.uuid Encoder.uuid Decoder.uuid+    ,+    stdRoundtrip "int2_int16" Gens.auto PTI.int2 Encoder.int2_int16 Decoder.int+    ,+    stdRoundtrip "int2_word16" Gens.auto PTI.int2 Encoder.int2_word16 Decoder.int+    ,+    stdRoundtrip "int4_int32" Gens.auto PTI.int4 Encoder.int4_int32 Decoder.int+    ,+    stdRoundtrip "int4_word32" Gens.auto PTI.int4 Encoder.int4_word32 Decoder.int+    ,+    stdRoundtrip "int8_int64" Gens.auto PTI.int8 Encoder.int8_int64 Decoder.int+    ,+    stdRoundtrip "int8_word64" Gens.auto PTI.int8 Encoder.int8_word64 Decoder.int+    ,+    stdRoundtrip "bool" Gens.auto PTI.bool Encoder.bool Decoder.bool+    ,+    stdRoundtrip "date" Gens.auto PTI.date Encoder.date Decoder.date+    ,+    let+      decoder =+        Decoder.array $+        Decoder.arrayDimension replicateM $+        Decoder.arrayDimension replicateM $+        Decoder.arrayNonNullValue $+        Decoder.int+      in+        select "SELECT ARRAY[ARRAY[1,2],ARRAY[3,4]]" (const decoder) ([[1,2],[3,4]] :: [[Int]])+    ,+    let+      encoder =+        Encoder.array (PTI.oidWord32 (PTI.ptiOID PTI.int8)) $+        Encoder.arrayDimension foldl' $+        Encoder.arrayDimension foldl' $+        Encoder.arrayDimension foldl' $+        Encoder.arrayValue $+        Encoder.int8_int64+      decoder =+        Decoder.array $+        Decoder.arrayDimension replicateM $+        Decoder.arrayDimension replicateM $+        Decoder.arrayDimension replicateM $+        Decoder.arrayNonNullValue $+        Decoder.int+      in+        arrayCodec (Gens.array3 Gens.auto) encoder decoder+    ,+    let+      pti =+        PTI.text+      encoder =+        Encoder.array (PTI.oidWord32 (PTI.ptiOID pti)) $+        Encoder.arrayDimension foldl' $+        Encoder.arrayDimension foldl' $+        Encoder.arrayDimension foldl' $+        Encoder.arrayValue $+        Encoder.text_strict+      decoder =+        Decoder.array $+        Decoder.arrayDimension replicateM $+        Decoder.arrayDimension replicateM $+        Decoder.arrayDimension replicateM $+        Decoder.arrayNonNullValue $+        Decoder.text_strict+      in+        arrayRoundtrip (Gens.array3 Gens.text) pti encoder decoder+  ]++textual =+  testGroup "Textual format" $+  [+    test "numeric" Gens.scientific PTI.numeric TextEncoder.numeric (const Decoder.numeric)+    ,+    test "float4" Gens.auto PTI.float4 TextEncoder.float4 (const Decoder.float4)+    ,+    test "float8" Gens.auto PTI.float8 TextEncoder.float8 (const Decoder.float8)+    ,+    test "uuid" Gens.uuid PTI.uuid TextEncoder.uuid (const Decoder.uuid)+    ,+    test "int2_int16" Gens.auto PTI.int2 TextEncoder.int2_int16 (const Decoder.int)+    ,+    test "int2_word16" Gens.postgresInt PTI.int2 TextEncoder.int2_word16 (const Decoder.int)+    ,+    test "int4_int32" Gens.auto PTI.int4 TextEncoder.int4_int32 (const Decoder.int)+    ,+    test "int4_word32" Gens.postgresInt PTI.int4 TextEncoder.int4_word32 (const Decoder.int)+    ,+    test "int8_int64" Gens.auto PTI.int8 TextEncoder.int8_int64 (const Decoder.int)+    ,+    test "int8_word64" Gens.postgresInt PTI.int8 TextEncoder.int8_word64 (const Decoder.int)+    ,+    test "bool" Gens.auto PTI.bool TextEncoder.bool (const Decoder.bool)+  ]+  where+    test typeName gen pti encoder decoder =+      QuickCheck.testProperty (typeName <> " roundtrip") $+      QuickCheck.forAll gen $ Properties.textRoundtrip (PTI.oidPQ (PTI.ptiOID pti)) encoder decoder++arrayCodec gen encoder decoder =+  QuickCheck.testProperty ("Array codec") $+  QuickCheck.forAll gen $+  \value -> (QuickCheck.===) (Right value) (Decoder.run decoder (Encoder.run encoder value))++arrayRoundtrip gen pti encoder decoder =+  QuickCheck.testProperty ("Array roundtrip") $+  QuickCheck.forAll gen $ Properties.stdRoundtrip (PTI.oidPQ (fromJust (PTI.ptiArrayOID pti))) encoder decoder++stdRoundtrip typeName gen pti encoder decoder =+  QuickCheck.testProperty (typeName <> " roundtrip") $+  QuickCheck.forAll gen $ Properties.stdRoundtrip (PTI.oidPQ (PTI.ptiOID pti)) encoder decoder++timeRoundtrip typeName gen pti encoder decoder =+  QuickCheck.testProperty (typeName <> " roundtrip") $+  QuickCheck.forAll gen $ Properties.roundtrip (PTI.oidPQ (PTI.ptiOID pti)) encoder decoder++select statement decoder value =+  HUnit.testCase (show statement) $+  HUnit.assertEqual "" (Right value) $+  unsafePerformIO $ IO.parameterlessStatement statement decoder value+
+ tasty/Main/Apx.hs view
@@ -0,0 +1,52 @@+module Main.Apx where++import Main.Prelude+++-- |+-- A wrapper which provides a type-specific 'Eq' instance+-- with approximate comparison.+newtype Apx a =+  Apx { unApx :: a }+  deriving (Show)++instance (Eq (Apx a), Eq (Apx b)) => Eq (Apx (a, b)) where+  (==) (Apx (a1, a2)) (Apx (b1, b2)) =+    Apx a1 == Apx b1 &&+    Apx a2 == Apx b2++instance Eq (Apx LocalTime) where+  (==) (Apx a) (Apx b) =+    localTimeRep a == localTimeRep b++instance Eq (Apx UTCTime) where+  (==) (Apx a) (Apx b) =+    utcTimeApxRep a == utcTimeApxRep b++instance Eq (Apx TimeOfDay) where+  (==) (Apx a) (Apx b) =+    timeOfDayApxRep a == timeOfDayApxRep b++instance Eq (Apx TimeZone) where+  (==) (Apx a) (Apx b) =+    a == b+++utcTimeApxRep (UTCTime d d') =+  (d, picoApxRep (unsafeCoerce d'))++localTimeRep (LocalTime d t) =+  (d, timeOfDayApxRep t)++timetzApxRep (t, tz) = +  (timeOfDayApxRep t, tz)++timeOfDayApxRep :: TimeOfDay -> (Int, Int, Integer)+timeOfDayApxRep (TimeOfDay h m s) =+  (h, m, picoApxRep s)++picoApxRep :: Pico -> Integer+picoApxRep s =+  let p = unsafeCoerce s :: Integer+      in floor (p % 10^6)+
+ tasty/Main/DB.hs view
@@ -0,0 +1,104 @@+module Main.DB+(+  module LibPQ,+  session,+  oneRow,+  unit,+  integerDatetimes,+)+where++import Main.Prelude+import Control.Monad.Trans.Reader+import Control.Monad.Trans.Either+import Control.Monad.IO.Class+import Database.PostgreSQL.LibPQ as LibPQ+import qualified Data.ByteString as ByteString; import Data.ByteString (ByteString)+++type Session =+  EitherT ByteString (ReaderT Connection IO)++session :: Session a -> IO (Either ByteString a)+session m =+  do+    c <- connect+    initConnection c+    r <- runReaderT (runEitherT m) c+    finish c+    return r++oneRow :: ByteString -> [Maybe (Oid, ByteString, Format)] -> Format -> Session ByteString+oneRow statement params outFormat =+  do+    Just result <- result statement params outFormat+    Just result <- liftIO $ getvalue result 0 0+    return result++unit :: ByteString -> [Maybe (Oid, ByteString, Format)] -> Session ()+unit statement params =+  void $ result statement params Binary++result :: ByteString -> [Maybe (Oid, ByteString, Format)] -> Format -> Session (Maybe Result)+result statement params outFormat =+  do+    result <- EitherT $ ReaderT $ \connection -> fmap Right $ execParams connection statement params outFormat+    checkResult result+    return result++checkResult :: Maybe Result -> Session ()+checkResult result =+  EitherT $ ReaderT $ \connection -> do+    case result of+      Just result -> do+        resultErrorField result DiagMessagePrimary >>= maybe (return (Right ())) (return . Left)+      Nothing -> do+        m <- errorMessage connection+        return $ Left $ maybe "Fatal PQ error" (\m -> "Fatal PQ error: " <> m) m++integerDatetimes :: Session Bool+integerDatetimes =+  lift (ReaderT getIntegerDatetimes)++-- *+-------------------------++connect :: IO Connection+connect =+  connectdb bs+  where+    bs = +      ByteString.intercalate " " components+      where+        components = +          [+            "host=" <> host,+            "port=" <> (fromString . show) port,+            "user=" <> user,+            "password=" <> password,+            "dbname=" <> db+          ]+          where+            host = "localhost"+            port = 5432+            user = "postgres"+            password = ""+            db = "postgres"++initConnection :: Connection -> IO ()+initConnection c =+  void $ exec c $ mconcat $ map (<> ";") $ +    [ +      "SET client_min_messages TO WARNING",+      "SET client_encoding = 'UTF8'",+      "SET intervalstyle = 'postgres'"+    ]++getIntegerDatetimes :: Connection -> IO Bool+getIntegerDatetimes c =+  fmap parseResult $ parameterStatus c "integer_datetimes"+  where+    parseResult = +      \case+        Just "on" -> True+        _ -> False
+ tasty/Main/Gens.hs view
@@ -0,0 +1,118 @@+module Main.Gens where++import Main.Prelude hiding (assert, isRight, isLeft)+import Test.QuickCheck+import Test.QuickCheck.Instances+import qualified Main.PTI as PTI+import qualified Data.Scientific as Scientific+import qualified Data.UUID as UUID+import qualified Data.Vector as Vector+import qualified PostgreSQL.Binary.Data as Data+import qualified PostgreSQL.Binary.Encoder as Encoder+import qualified Data.Text as Text+++-- * Generators+-------------------------++auto :: Arbitrary a => Gen a+auto =+  arbitrary++postgresInt :: (Bounded a, Ord a, Integral a, Arbitrary a) => Gen a+postgresInt =+  arbitrary >>= \x -> if x > halfMaxBound then postgresInt else pure x+  where+    halfMaxBound =+      div maxBound 2++text :: Gen Text+text =+  arbitrary >>= \x -> if Text.find (== '\NUL') x == Nothing then return x else text++char :: Gen Char+char =+  arbitrary >>= \x -> if x /= '\NUL' then return x else char++scientific :: Gen Scientific+scientific =+  Scientific.scientific <$> arbitrary <*> arbitrary++microsTimeOfDay :: Gen TimeOfDay+microsTimeOfDay =+  fmap timeToTimeOfDay $ fmap picosecondsToDiffTime $ fmap (* (10^6)) $ +    choose (0, (10^6)*24*60*60)++microsLocalTime :: Gen LocalTime+microsLocalTime = +  LocalTime <$> arbitrary <*> microsTimeOfDay++microsUTCTime :: Gen UTCTime+microsUTCTime =+  localTimeToUTC <$> timeZone <*> microsLocalTime++intervalDiffTime :: Gen DiffTime+intervalDiffTime = do+  unsafeCoerce ((* (10^6)) <$> choose (uMin, uMax) :: Gen Integer)+  where+    uMin = unsafeCoerce minInterval `div` 10^6+    uMax = unsafeCoerce maxInterval `div` 10^6++timeZone :: Gen TimeZone+timeZone =+  minutesToTimeZone <$> choose (- 60 * 12 + 1, 60 * 12)++timetz :: Gen (TimeOfDay, TimeZone)+timetz =+  (,) <$> microsTimeOfDay <*> timeZone++uuid :: Gen UUID.UUID+uuid =+  UUID.fromWords <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary++arrayRep :: Gen (Word32, Data.Array)+arrayRep =+  do+    ndims <- choose (1, 4)+    dims <- Vector.replicateM ndims dimGen+    (valueGen', oid, arrayOID) <- valueGen+    values <- Vector.replicateM (dimsToNValues dims) valueGen'+    let nulls = Vector.elem Nothing values+    return (arrayOID, (dims, values, nulls, oid))+  where+    dimGen =+      (,) <$> choose (1, 7) <*> pure 1+    valueGen =+      do+        (pti, gen) <- elements [(PTI.int8, mkGen Encoder.int8_int64),+                                (PTI.bool, mkGen Encoder.bool),+                                (PTI.date, mkGen Encoder.date),+                                (PTI.text, mkGen Encoder.text_strict),+                                (PTI.bytea, mkGen Encoder.bytea_strict)]+        return (gen, PTI.oidWord32 (PTI.ptiOID pti), PTI.oidWord32 (fromJust (PTI.ptiArrayOID pti)))+      where+        mkGen renderer =+          fmap (fmap (convert . renderer)) arbitrary+    dimsToNValues =+      Vector.product . fmap dimensionWidth+      where+        dimensionWidth (x, _) = fromIntegral x++array3 :: Gen a -> Gen [[[a]]]+array3 gen =+  do+    width1 <- choose (1, 10)+    width2 <- choose (1, 10)+    width3 <- choose (1, 10)+    replicateM width1 (replicateM width2 (replicateM width3 gen))+++-- * Constants+-------------------------++maxInterval :: DiffTime = +  unsafeCoerce $ +    (truncate (1780000 * 365.2425 * 24 * 60 * 60 * 10 ^ 12 :: Rational) :: Integer)++minInterval :: DiffTime = +  negate maxInterval
+ tasty/Main/IO.hs view
@@ -0,0 +1,54 @@+-- |+-- Specific IO Actions+module Main.IO where++import Main.Prelude hiding (assert, isRight, isLeft)+import Test.QuickCheck+import Test.QuickCheck.Instances+import qualified Main.PTI as PTI+import qualified Main.DB as DB+import qualified Main.TextEncoder as TextEncoder +import qualified Data.Scientific as Scientific+import qualified Data.UUID as UUID+import qualified Data.Vector as Vector+import qualified Data.Text.Encoding as Text+import qualified PostgreSQL.Binary.Data as Data+import qualified PostgreSQL.Binary.Encoder as Encoder+import qualified PostgreSQL.Binary.Decoder as Decoder+++textRoundtrip :: DB.Oid -> TextEncoder.Encoder a -> (Bool -> Decoder.Decoder a) -> a -> IO (Either Text a)+textRoundtrip oid encoder decoder value =+  fmap (either (Left . Text.decodeUtf8) id) $+  DB.session $ do+    integerDatetimes <- DB.integerDatetimes+    bytes <- DB.oneRow "SELECT $1" (params integerDatetimes) DB.Binary+    return $ Decoder.run (decoder integerDatetimes) bytes+  where+    params integerDatetimes =+      [ Just ( oid , bytes , DB.Text ) ]+      where+        bytes =+          (convert . encoder) value++roundtrip :: DB.Oid -> (Bool -> Encoder.Encoder a) -> (Bool -> Decoder.Decoder a) -> a -> IO (Either Text a)+roundtrip oid encoder decoder value =+  fmap (either (Left . Text.decodeUtf8) id) $+  DB.session $ do+    integerDatetimes <- DB.integerDatetimes+    bytes <- DB.oneRow "SELECT $1" (params integerDatetimes) DB.Binary+    return $ Decoder.run (decoder integerDatetimes) bytes+  where+    params integerDatetimes =+      [ Just ( oid , bytes , DB.Binary ) ]+      where+        bytes =+          (convert . encoder integerDatetimes) value++parameterlessStatement :: ByteString -> (Bool -> Decoder.Decoder a) -> a -> IO (Either Text a)+parameterlessStatement statement decoder value =+  fmap (either (Left . Text.decodeUtf8) id) $+  DB.session $ do+    integerDatetimes <- DB.integerDatetimes+    bytes <- DB.oneRow statement [] DB.Binary+    return $ Decoder.run (decoder integerDatetimes) bytes
+ tasty/Main/PTI.hs view
@@ -0,0 +1,93 @@+module Main.PTI where++import BasePrelude hiding (bool)+import qualified Database.PostgreSQL.LibPQ as LibPQ+++-- | A Postgresql type info+data PTI = PTI { ptiOID :: !OID, ptiArrayOID :: !(Maybe OID) }++-- | A Word32 and a LibPQ representation of an OID+data OID = OID { oidWord32 :: !Word32, oidPQ :: !LibPQ.Oid }++mkOID :: Word32 -> OID+mkOID x =+  OID x ((LibPQ.Oid . fromIntegral) x)++mkPTI :: Word32 -> Maybe Word32 -> PTI+mkPTI oid arrayOID =+  PTI (mkOID oid) (fmap mkOID arrayOID)+++-- * Constants+-------------------------++abstime         = mkPTI 702  (Just 1023)+aclitem         = mkPTI 1033 (Just 1034)+bit             = mkPTI 1560 (Just 1561)+bool            = mkPTI 16   (Just 1000)+box             = mkPTI 603  (Just 1020)+bpchar          = mkPTI 1042 (Just 1014)+bytea           = mkPTI 17   (Just 1001)+char            = mkPTI 18   (Just 1002)+cid             = mkPTI 29   (Just 1012)+cidr            = mkPTI 650  (Just 651)+circle          = mkPTI 718  (Just 719)+cstring         = mkPTI 2275 (Just 1263)+date            = mkPTI 1082 (Just 1182)+daterange       = mkPTI 3912 (Just 3913)+float4          = mkPTI 700  (Just 1021)+float8          = mkPTI 701  (Just 1022)+gtsvector       = mkPTI 3642 (Just 3644)+inet            = mkPTI 869  (Just 1041)+int2            = mkPTI 21   (Just 1005)+int2vector      = mkPTI 22   (Just 1006)+int4            = mkPTI 23   (Just 1007)+int4range       = mkPTI 3904 (Just 3905)+int8            = mkPTI 20   (Just 1016)+int8range       = mkPTI 3926 (Just 3927)+interval        = mkPTI 1186 (Just 1187)+json            = mkPTI 114  (Just 199)+line            = mkPTI 628  (Just 629)+lseg            = mkPTI 601  (Just 1018)+macaddr         = mkPTI 829  (Just 1040)+money           = mkPTI 790  (Just 791)+name            = mkPTI 19   (Just 1003)+numeric         = mkPTI 1700 (Just 1231)+numrange        = mkPTI 3906 (Just 3907)+oid             = mkPTI 26   (Just 1028)+oidvector       = mkPTI 30   (Just 1013)+path            = mkPTI 602  (Just 1019)+point           = mkPTI 600  (Just 1017)+polygon         = mkPTI 604  (Just 1027)+record          = mkPTI 2249 (Just 2287)+refcursor       = mkPTI 1790 (Just 2201)+regclass        = mkPTI 2205 (Just 2210)+regconfig       = mkPTI 3734 (Just 3735)+regdictionary   = mkPTI 3769 (Just 3770)+regoper         = mkPTI 2203 (Just 2208)+regoperator     = mkPTI 2204 (Just 2209)+regproc         = mkPTI 24   (Just 1008)+regprocedure    = mkPTI 2202 (Just 2207)+regtype         = mkPTI 2206 (Just 2211)+reltime         = mkPTI 703  (Just 1024)+text            = mkPTI 25   (Just 1009)+tid             = mkPTI 27   (Just 1010)+time            = mkPTI 1083 (Just 1183)+timestamp       = mkPTI 1114 (Just 1115)+timestamptz     = mkPTI 1184 (Just 1185)+timetz          = mkPTI 1266 (Just 1270)+tinterval       = mkPTI 704  (Just 1025)+tsquery         = mkPTI 3615 (Just 3645)+tsrange         = mkPTI 3908 (Just 3909)+tstzrange       = mkPTI 3910 (Just 3911)+tsvector        = mkPTI 3614 (Just 3643)+txid_snapshot   = mkPTI 2970 (Just 2949)+unknown         = mkPTI 705  Nothing+uuid            = mkPTI 2950 (Just 2951)+varbit          = mkPTI 1562 (Just 1563)+varchar         = mkPTI 1043 (Just 1015)+void            = mkPTI 2278 Nothing+xid             = mkPTI 28   (Just 1011)+xml             = mkPTI 142  (Just 143)+
+ tasty/Main/Prelude.hs view
@@ -0,0 +1,100 @@+module Main.Prelude+( +  module Exports,+  LazyByteString,+  ByteStringBuilder,+  LazyText,+  TextBuilder,+  bug,+  bottom,+  mapLeft,+  joinMap,+)+where+++-- base-prelude+-------------------------+import BasePrelude as Exports hiding (assert, Data, fail)++-- transformers+-------------------------+import Control.Monad.Trans.State.Strict as Exports hiding (liftCallCC, liftCatch)+import Control.Monad.Trans.Reader as Exports hiding (liftCallCC, liftCatch)+import Control.Monad.Trans.Class as Exports+import Data.Functor.Identity as Exports++-- conversion+-------------------------+import Conversion as Exports+import Conversion.Text ()+import Conversion.ByteString ()++-- bytestring+-------------------------+import Data.ByteString as Exports (ByteString)++-- text+-------------------------+import Data.Text as Exports (Text)++-- vector+-------------------------+import Data.Vector as Exports (Vector)++-- scientific+-------------------------+import Data.Scientific as Exports (Scientific)++-- uuid+-------------------------+import Data.UUID as Exports (UUID)++-- time+-------------------------+import Data.Time as Exports++-- placeholders+-------------------------+import Development.Placeholders as Exports++-- loch-th+-------------------------+import Debug.Trace.LocationTH as Exports++-- custom+-------------------------+import qualified Data.ByteString.Lazy+import qualified Data.ByteString.Builder+import qualified Data.Text.Lazy+import qualified Data.Text.Lazy.Builder+import qualified Debug.Trace.LocationTH+++type LazyByteString =+  Data.ByteString.Lazy.ByteString++type ByteStringBuilder =+  Data.ByteString.Builder.Builder++type LazyText =+  Data.Text.Lazy.Text++type TextBuilder =+  Data.Text.Lazy.Builder.Builder+++bug = [e| $(Debug.Trace.LocationTH.failure) . (msg <>) |]+  where+    msg = "A \"postgresql-binary\" package bug: " :: String++bottom = [e| $bug "Bottom evaluated" |]++{-# INLINE mapLeft #-}+mapLeft :: (a -> b) -> Either a x -> Either b x+mapLeft f =+  either (Left . f) Right++joinMap :: Monad m => (a -> m b) -> m a -> m b+joinMap f =+  join . fmap f
+ tasty/Main/Properties.hs view
@@ -0,0 +1,29 @@+module Main.Properties where++import Main.Prelude hiding (assert, isRight, isLeft)+import Test.QuickCheck+import Test.QuickCheck.Instances+import qualified Data.Scientific as Scientific+import qualified Data.UUID as UUID+import qualified Data.Vector as Vector+import qualified PostgreSQL.Binary.Data as Data+import qualified PostgreSQL.Binary.Encoder as Encoder+import qualified PostgreSQL.Binary.Decoder as Decoder+import qualified Main.TextEncoder  as TextEncoder +import qualified Main.PTI as PTI+import qualified Main.DB as DB+import qualified Main.IO as IO+++roundtrip :: (Show a, Eq a) => +  DB.Oid -> (Bool -> Encoder.Encoder a) -> (Bool -> Decoder.Decoder a) -> a -> Property+roundtrip oid encoder decoder value =+  Right value === unsafePerformIO (IO.roundtrip oid encoder decoder value)++stdRoundtrip :: (Show a, Eq a) => DB.Oid -> Encoder.Encoder a -> Decoder.Decoder a -> a -> Property+stdRoundtrip oid encoder decoder value =+  roundtrip oid (const encoder) (const decoder) value++textRoundtrip :: (Show a, Eq a) => DB.Oid -> TextEncoder.Encoder a -> (Bool -> Decoder.Decoder a) -> a -> Property+textRoundtrip oid encoder decoder value =+  Right value === unsafePerformIO (IO.textRoundtrip oid encoder decoder value)
+ tasty/Main/TextEncoder.hs view
@@ -0,0 +1,62 @@+-- |+-- Encoders to text format.+module Main.TextEncoder  where++import Main.Prelude hiding (maybe, bool)+import Data.ByteString.Builder+import qualified Data.ByteString.Builder.Scientific+import qualified Data.Text.Encoding+import qualified Data.UUID+import qualified Main.Prelude as Prelude++type Encoder a =+  a -> Builder++bool :: Encoder Bool+bool =+  byteString . Prelude.bool "false" "true"++int2_int16 :: Encoder Int16+int2_int16 =+  int16Dec+ +int4_int32 :: Encoder Int32+int4_int32 =+  int32Dec+ +int8_int64 :: Encoder Int64+int8_int64 =+  int64Dec++int2_word16 :: Encoder Word16+int2_word16 =+  word16Dec+ +int4_word32 :: Encoder Word32+int4_word32 =+  word32Dec+ +int8_word64 :: Encoder Word64+int8_word64 =+  word64Dec++float4 :: Encoder Float+float4 =+  floatDec++float8 :: Encoder Double+float8 =+  doubleDec++numeric :: Encoder Scientific+numeric =+  Data.ByteString.Builder.Scientific.scientificBuilder++uuid :: Encoder UUID+uuid =+  byteString . Data.UUID.toASCIIBytes++bytea_strict :: Encoder ByteString+bytea_strict =+  byteString+