postgresql-simple 0.4.10.0 → 0.5.0.0
raw patch · 20 files changed
+1663/−771 lines, 20 filesdep +bytestring-builderdep +uuid-typesdep −blaze-builderdep −blaze-textualdep −uuiddep ~basedep ~bytestring
Dependencies added: bytestring-builder, uuid-types
Dependencies removed: blaze-builder, blaze-textual, uuid
Dependency ranges changed: base, bytestring
Files
- CONTRIBUTORS +7/−0
- postgresql-simple.cabal +7/−6
- src/Database/PostgreSQL/Simple.hs +94/−26
- src/Database/PostgreSQL/Simple/BuiltinTypes.hs +0/−428
- src/Database/PostgreSQL/Simple/Compat.hs +40/−0
- src/Database/PostgreSQL/Simple/Errors.hs +3/−0
- src/Database/PostgreSQL/Simple/FromField.hs +13/−18
- src/Database/PostgreSQL/Simple/HStore/Implementation.hs +10/−11
- src/Database/PostgreSQL/Simple/Internal.hs +13/−10
- src/Database/PostgreSQL/Simple/LargeObjects.hs +1/−1
- src/Database/PostgreSQL/Simple/Range.hs +313/−0
- src/Database/PostgreSQL/Simple/SqlQQ.hs +9/−7
- src/Database/PostgreSQL/Simple/Time/Implementation.hs +33/−190
- src/Database/PostgreSQL/Simple/Time/Internal/Parser.hs +192/−0
- src/Database/PostgreSQL/Simple/Time/Internal/Printer.hs +123/−0
- src/Database/PostgreSQL/Simple/ToField.hs +45/−40
- src/Database/PostgreSQL/Simple/ToField.hs-boot +1/−1
- src/Database/PostgreSQL/Simple/TypeInfo/Static.hs +754/−30
- src/Database/PostgreSQL/Simple/Types.hs +3/−3
- test/Main.hs +2/−0
CONTRIBUTORS view
@@ -20,3 +20,10 @@ Chris Allen <cma@bitemyapp.com> Simon Hengel <sol@typeful.net> Tom Ellis <tom-2013@purelyagile.com>+Mike Ledger <mike@quasimal.com>+João Cristóvão <jmacristovao@gmail.com>+Bardur Arantsson <bardur@scientician.net>+Travis Staton <hello@travisstaton.com>+Sam Rijs <srijs@airpost.net>+Janne Hellsten <jjhellst@gmail.com>+Timmy Tofu <timmytofu@users.noreply.github.com>
postgresql-simple.cabal view
@@ -1,5 +1,5 @@ Name: postgresql-simple-Version: 0.4.10.0+Version: 0.5.0.0 Synopsis: Mid-Level PostgreSQL client library Description: Mid-Level PostgreSQL client library, forked from mysql-simple.@@ -22,7 +22,6 @@ Exposed-modules: Database.PostgreSQL.Simple Database.PostgreSQL.Simple.Arrays- Database.PostgreSQL.Simple.BuiltinTypes Database.PostgreSQL.Simple.Copy Database.PostgreSQL.Simple.FromField Database.PostgreSQL.Simple.FromRow@@ -31,6 +30,7 @@ Database.PostgreSQL.Simple.HStore.Internal Database.PostgreSQL.Simple.Notification Database.PostgreSQL.Simple.Ok+ Database.PostgreSQL.Simple.Range Database.PostgreSQL.Simple.SqlQQ Database.PostgreSQL.Simple.Time Database.PostgreSQL.Simple.Time.Internal@@ -49,15 +49,16 @@ Database.PostgreSQL.Simple.Compat Database.PostgreSQL.Simple.HStore.Implementation Database.PostgreSQL.Simple.Time.Implementation+ Database.PostgreSQL.Simple.Time.Internal.Parser+ Database.PostgreSQL.Simple.Time.Internal.Printer Database.PostgreSQL.Simple.TypeInfo.Types Build-depends: aeson >= 0.6, attoparsec >= 0.10.3, base < 5,- blaze-builder,- blaze-textual, bytestring >= 0.9,+ bytestring-builder, case-insensitive, containers, hashable,@@ -66,7 +67,7 @@ text >= 0.11.1, time, transformers,- uuid >= 1.3.1,+ uuid-types >= 1.0.0, scientific, vector @@ -82,7 +83,7 @@ source-repository this type: git location: http://github.com/lpsmith/postgresql-simple- tag: v0.4.10.0+ tag: v0.5.0.0 test-suite test type: exitcode-stdio-1.0
src/Database/PostgreSQL/Simple.hs view
@@ -42,7 +42,7 @@ -- ** Modifying multiple rows at once -- $many - -- ** @RETURNING@: modifications that returns results+ -- ** @RETURNING@: modifications that return results -- $returning -- * Extracting results@@ -93,6 +93,14 @@ , forEach , forEach_ , returning+ -- ** Queries that stream results taking a parser as an argument+ , foldWith+ , foldWithOptionsAndParser+ , foldWith_+ , foldWithOptionsAndParser_+ , forEachWith+ , forEachWith_+ , returningWith -- * Statements that do not return results , execute , execute_@@ -110,10 +118,8 @@ , formatQuery ) where -import Blaze.ByteString.Builder- ( Builder, fromByteString, toByteString )-import Blaze.ByteString.Builder.Char8 (fromChar)-import Blaze.Text ( integral )+import Data.ByteString.Builder+ ( Builder, byteString, char8, intDec ) import Control.Applicative ((<$>)) import Control.Exception as E import Control.Monad (foldM)@@ -121,7 +127,7 @@ import Data.Int (Int64) import Data.List (intersperse) import Data.Monoid (mconcat)-import Database.PostgreSQL.Simple.Compat ( (<>) )+import Database.PostgreSQL.Simple.Compat ( (<>), toByteString ) import Database.PostgreSQL.Simple.FromField (ResultError(..)) import Database.PostgreSQL.Simple.FromRow (FromRow(..)) import Database.PostgreSQL.Simple.Ok@@ -173,9 +179,9 @@ case parseTemplate template of Just (before, qbits, after) -> do bs <- mapM (buildQuery conn q qbits . toRow) qs- return . toByteString . mconcat $ fromByteString before :- intersperse (fromChar ',') bs ++- [fromByteString after]+ return . toByteString . mconcat $ byteString before :+ intersperse (char8 ',') bs +++ [byteString after] Nothing -> fmtError "syntax error in multi-row template" q [] -- Split the input string into three pieces, @before@, @qbits@, and @after@,@@ -280,7 +286,7 @@ zipParams (split template) <$> mapM (buildAction conn q xs) xs where split s = let (h,t) = B.break (=='?') s- in fromByteString h+ in byteString h : if B.null t then [] else split (B.tail t)@@ -351,10 +357,13 @@ -- -- Throws 'FormatError' if the query could not be formatted correctly. returning :: (ToRow q, FromRow r) => Connection -> Query -> [q] -> IO [r]-returning _ _ [] = return []-returning conn q qs = do+returning = returningWith fromRow++returningWith :: (ToRow q) => RowParser r -> Connection -> Query -> [q] -> IO [r]+returningWith _ _ _ [] = return []+returningWith parser conn q qs = do result <- exec conn =<< formatMany conn q qs- finishQuery conn q result+ finishQueryWith parser conn q result -- | Perform a @SELECT@ or other SQL query that is expected to return -- results. All results are retrieved and converted before this@@ -429,6 +438,17 @@ -> IO a fold = foldWithOptions defaultFoldOptions +-- | A version of 'fold' taking a parser as an argument+foldWith :: ( ToRow params )+ => RowParser row+ -> Connection+ -> Query+ -> params+ -> a+ -> (a -> row -> IO a)+ -> IO a+foldWith = foldWithOptionsAndParser defaultFoldOptions+ -- | Number of rows to fetch at a time. 'Automatic' currently defaults -- to 256 rows, although it might be nice to make this more intelligent -- based on e.g. the average size of the rows.@@ -463,9 +483,21 @@ -> a -> (a -> row -> IO a) -> IO a-foldWithOptions opts conn template qs a f = do+foldWithOptions opts = foldWithOptionsAndParser opts fromRow++-- | A version of 'foldWithOptions' taking a parser as an argument+foldWithOptionsAndParser :: (ToRow params)+ => FoldOptions+ -> RowParser row+ -> Connection+ -> Query+ -> params+ -> a+ -> (a -> row -> IO a)+ -> IO a+foldWithOptionsAndParser opts parser conn template qs a f = do q <- formatQuery conn template qs- doFold opts conn template (Query q) a f+ doFold opts parser conn template (Query q) a f -- | A version of 'fold' that does not perform query substitution. fold_ :: (FromRow r) =>@@ -476,6 +508,14 @@ -> IO a fold_ = foldWithOptions_ defaultFoldOptions +-- | A version of 'foldWith' taking a parser as an argument+foldWith_ :: RowParser r+ -> Connection+ -> Query+ -> a+ -> (a -> r -> IO a)+ -> IO a+foldWith_ = foldWithOptionsAndParser_ defaultFoldOptions foldWithOptions_ :: (FromRow r) => FoldOptions@@ -484,18 +524,27 @@ -> a -- ^ Initial state for result consumer. -> (a -> r -> IO a) -- ^ Result consumer. -> IO a-foldWithOptions_ opts conn query a f = doFold opts conn query query a f+foldWithOptions_ opts conn query a f = doFold opts fromRow conn query query a f +-- | A version of 'foldWithOptions_' taking a parser as an argument+foldWithOptionsAndParser_ :: FoldOptions+ -> RowParser r+ -> Connection+ -> Query -- ^ Query.+ -> a -- ^ Initial state for result consumer.+ -> (a -> r -> IO a) -- ^ Result consumer.+ -> IO a+foldWithOptionsAndParser_ opts parser conn query a f = doFold opts parser conn query query a f -doFold :: ( FromRow row )- => FoldOptions+doFold :: FoldOptions+ -> RowParser row -> Connection -> Query -> Query -> a -> (a -> row -> IO a) -> IO a-doFold FoldOptions{..} conn _template q a0 f = do+doFold FoldOptions{..} parser conn _template q a0 f = do stat <- withConnection conn PQ.transactionStatus case stat of PQ.TransIdle -> withTransactionMode transactionMode conn go@@ -518,11 +567,11 @@ _ <- execute_ conn $ mconcat [ "DECLARE ", name, " NO SCROLL CURSOR FOR ", q ] return name- fetch (Query name) = query_ conn $- Query (toByteString (fromByteString "FETCH FORWARD "- <> integral chunkSize- <> fromByteString " FROM "- <> fromByteString name+ fetch (Query name) = queryWith_ parser conn $+ Query (toByteString (byteString "FETCH FORWARD "+ <> intDec chunkSize+ <> byteString " FROM "+ <> byteString name )) close name = (execute_ conn ("CLOSE " <> name) >> return ()) `E.catch` \ex ->@@ -553,17 +602,36 @@ -> q -- ^ Query parameters. -> (r -> IO ()) -- ^ Result consumer. -> IO ()-forEach conn template qs = fold conn template qs () . const+forEach = forEachWith fromRow {-# INLINE forEach #-} +-- | A version of 'forEach' taking a parser as an argument+forEachWith :: ( ToRow q )+ => RowParser r+ -> Connection+ -> Query+ -> q+ -> (r -> IO ())+ -> IO ()+forEachWith parser conn template qs = foldWith parser conn template qs () . const+{-# INLINE forEachWith #-}+ -- | A version of 'forEach' that does not perform query substitution. forEach_ :: (FromRow r) => Connection -> Query -- ^ Query template. -> (r -> IO ()) -- ^ Result consumer. -> IO ()-forEach_ conn template = fold_ conn template () . const+forEach_ = forEachWith_ fromRow {-# INLINE forEach_ #-}++forEachWith_ :: RowParser r+ -> Connection+ -> Query+ -> (r -> IO ())+ -> IO ()+forEachWith_ parser conn template = foldWith_ parser conn template () . const+{-# INLINE forEachWith_ #-} forM' :: (Ord n, Num n) => n -> n -> (n -> IO a) -> IO [a] forM' lo hi m = loop hi []
− src/Database/PostgreSQL/Simple/BuiltinTypes.hs
@@ -1,428 +0,0 @@-{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-}----------------------------------------------------------------------------------- |--- Module: Database.PostgreSQL.Simple.BuiltinTypes--- Copyright: (c) 2011-2012 Leon P Smith--- License: BSD3--- Maintainer: Leon P Smith <leon@melding-monads.com>--- Stability: experimental-------------------------------------------------------------------------------------- Note that this file is generated by tools/GenBuiltinTypes.hs, and should--- not be edited directly--module Database.PostgreSQL.Simple.BuiltinTypes- {-# DEPRECATED "Use TypeInfo instead" #-}- ( BuiltinType (..)- , builtin2oid- , oid2builtin- , builtin2typname- , oid2typname- ) where--import Data.Typeable-import Data.ByteString (ByteString)-import qualified Database.PostgreSQL.LibPQ as PQ--data BuiltinType- = Bool- | ByteA- | Char- | Name- | Int8- | Int2- | Int4- | RegProc- | Text- | Oid- | Tid- | Xid- | Cid- | Xml- | Point- | LSeg- | Path- | Box- | Polygon- | Line- | Cidr- | Float4- | Float8- | AbsTime- | RelTime- | TInterval- | Unknown- | Circle- | Money- | MacAddr- | Inet- | BpChar- | VarChar- | Date- | Time- | Timestamp- | TimestampTZ- | Interval- | TimeTZ- | Bit- | VarBit- | Numeric- | RefCursor- | Record- | Void- | UUID- | JSON- | JSONB- deriving (Eq, Ord, Enum, Bounded, Read, Show, Typeable)--builtin2oid :: BuiltinType -> PQ.Oid-builtin2oid typ = PQ.Oid $ case typ of- Bool -> 16- ByteA -> 17- Char -> 18- Name -> 19- Int8 -> 20- Int2 -> 21- Int4 -> 23- RegProc -> 24- Text -> 25- Oid -> 26- Tid -> 27- Xid -> 28- Cid -> 29- Xml -> 142- Point -> 600- LSeg -> 601- Path -> 602- Box -> 603- Polygon -> 604- Line -> 628- Cidr -> 650- Float4 -> 700- Float8 -> 701- AbsTime -> 702- RelTime -> 703- TInterval -> 704- Unknown -> 705- Circle -> 718- Money -> 790- MacAddr -> 829- Inet -> 869- BpChar -> 1042- VarChar -> 1043- Date -> 1082- Time -> 1083- Timestamp -> 1114- TimestampTZ -> 1184- Interval -> 1186- TimeTZ -> 1266- Bit -> 1560- VarBit -> 1562- Numeric -> 1700- RefCursor -> 1790- Record -> 2249- Void -> 2278- UUID -> 2950- JSON -> 114- JSONB -> 3802--oid2builtin :: PQ.Oid -> Maybe BuiltinType-oid2builtin (PQ.Oid x) = case x of- 16 -> Just Bool- 17 -> Just ByteA- 18 -> Just Char- 19 -> Just Name- 20 -> Just Int8- 21 -> Just Int2- 23 -> Just Int4- 24 -> Just RegProc- 25 -> Just Text- 26 -> Just Oid- 27 -> Just Tid- 28 -> Just Xid- 29 -> Just Cid- 142 -> Just Xml- 600 -> Just Point- 601 -> Just LSeg- 602 -> Just Path- 603 -> Just Box- 604 -> Just Polygon- 628 -> Just Line- 650 -> Just Cidr- 700 -> Just Float4- 701 -> Just Float8- 702 -> Just AbsTime- 703 -> Just RelTime- 704 -> Just TInterval- 705 -> Just Unknown- 718 -> Just Circle- 790 -> Just Money- 829 -> Just MacAddr- 869 -> Just Inet- 1042 -> Just BpChar- 1043 -> Just VarChar- 1082 -> Just Date- 1083 -> Just Time- 1114 -> Just Timestamp- 1184 -> Just TimestampTZ- 1186 -> Just Interval- 1266 -> Just TimeTZ- 1560 -> Just Bit- 1562 -> Just VarBit- 1700 -> Just Numeric- 1790 -> Just RefCursor- 2249 -> Just Record- 2278 -> Just Void- 2950 -> Just UUID- 114 -> Just JSON- 3802 -> Just JSONB- _ -> Nothing--builtin2typname :: BuiltinType -> ByteString-builtin2typname typ = case typ of- Bool -> bool- ByteA -> bytea- Char -> char- Name -> name- Int8 -> int8- Int2 -> int2- Int4 -> int4- RegProc -> regproc- Text -> text- Oid -> oid- Tid -> tid- Xid -> xid- Cid -> cid- Xml -> xml- Point -> point- LSeg -> lseg- Path -> path- Box -> box- Polygon -> polygon- Line -> line- Cidr -> cidr- Float4 -> float4- Float8 -> float8- AbsTime -> abstime- RelTime -> reltime- TInterval -> tinterval- Unknown -> unknown- Circle -> circle- Money -> money- MacAddr -> macaddr- Inet -> inet- BpChar -> bpchar- VarChar -> varchar- Date -> date- Time -> time- Timestamp -> timestamp- TimestampTZ -> timestamptz- Interval -> interval- TimeTZ -> timetz- Bit -> bit- VarBit -> varbit- Numeric -> numeric- RefCursor -> refcursor- Record -> record- Void -> void- UUID -> uuid- JSON -> json- JSONB -> jsonb--oid2typname :: PQ.Oid -> Maybe ByteString-oid2typname (PQ.Oid x) = case x of- 16 -> Just bool- 17 -> Just bytea- 18 -> Just char- 19 -> Just name- 20 -> Just int8- 21 -> Just int2- 23 -> Just int4- 24 -> Just regproc- 25 -> Just text- 26 -> Just oid- 27 -> Just tid- 28 -> Just xid- 29 -> Just cid- 142 -> Just xml- 600 -> Just point- 601 -> Just lseg- 602 -> Just path- 603 -> Just box- 604 -> Just polygon- 628 -> Just line- 650 -> Just cidr- 700 -> Just float4- 701 -> Just float8- 702 -> Just abstime- 703 -> Just reltime- 704 -> Just tinterval- 705 -> Just unknown- 718 -> Just circle- 790 -> Just money- 829 -> Just macaddr- 869 -> Just inet- 1042 -> Just bpchar- 1043 -> Just varchar- 1082 -> Just date- 1083 -> Just time- 1114 -> Just timestamp- 1184 -> Just timestamptz- 1186 -> Just interval- 1266 -> Just timetz- 1560 -> Just bit- 1562 -> Just varbit- 1700 -> Just numeric- 1790 -> Just refcursor- 2249 -> Just record- 2278 -> Just void- 2950 -> Just uuid- 114 -> Just json- 3802 -> Just jsonb- _ -> Nothing--bool :: ByteString-bool = "bool"--bytea :: ByteString-bytea = "bytea"--char :: ByteString-char = "char"--name :: ByteString-name = "name"--int8 :: ByteString-int8 = "int8"--int2 :: ByteString-int2 = "int2"--int4 :: ByteString-int4 = "int4"--regproc :: ByteString-regproc = "regproc"--text :: ByteString-text = "text"--oid :: ByteString-oid = "oid"--tid :: ByteString-tid = "tid"--xid :: ByteString-xid = "xid"--cid :: ByteString-cid = "cid"--xml :: ByteString-xml = "xml"--point :: ByteString-point = "point"--lseg :: ByteString-lseg = "lseg"--path :: ByteString-path = "path"--box :: ByteString-box = "box"--polygon :: ByteString-polygon = "polygon"--line :: ByteString-line = "line"--cidr :: ByteString-cidr = "cidr"--float4 :: ByteString-float4 = "float4"--float8 :: ByteString-float8 = "float8"--abstime :: ByteString-abstime = "abstime"--reltime :: ByteString-reltime = "reltime"--tinterval :: ByteString-tinterval = "tinterval"--unknown :: ByteString-unknown = "unknown"--circle :: ByteString-circle = "circle"--money :: ByteString-money = "money"--macaddr :: ByteString-macaddr = "macaddr"--inet :: ByteString-inet = "inet"--bpchar :: ByteString-bpchar = "bpchar"--varchar :: ByteString-varchar = "varchar"--date :: ByteString-date = "date"--time :: ByteString-time = "time"--timestamp :: ByteString-timestamp = "timestamp"--timestamptz :: ByteString-timestamptz = "timestamptz"--interval :: ByteString-interval = "interval"--timetz :: ByteString-timetz = "timetz"--bit :: ByteString-bit = "bit"--varbit :: ByteString-varbit = "varbit"--numeric :: ByteString-numeric = "numeric"--refcursor :: ByteString-refcursor = "refcursor"--record :: ByteString-record = "record"--void :: ByteString-void = "void"--uuid :: ByteString-uuid = "uuid"--json :: ByteString-json = "json"--jsonb :: ByteString-jsonb = "jsonb"
src/Database/PostgreSQL/Simple/Compat.hs view
@@ -5,11 +5,24 @@ ( mask , (<>) , unsafeDupablePerformIO+ , toByteString+ , scientificBuilder+ , toPico+ , fromPico ) where import qualified Control.Exception as E import Data.Monoid+import Data.ByteString (ByteString)+import Data.ByteString.Lazy (toStrict)+import Data.ByteString.Builder (Builder, toLazyByteString) +#if MIN_VERSION_scientific(0,3,0)+import Data.Text.Lazy.Builder.Scientific (scientificBuilder)+#else+import Data.Scientific (scientificBuilder)+#endif+ #if __GLASGOW_HASKELL__ >= 702 import System.IO.Unsafe (unsafeDupablePerformIO) #elif __GLASGOW_HASKELL__ >= 611@@ -18,6 +31,12 @@ import GHC.IOBase (unsafeDupablePerformIO) #endif +import Data.Fixed (Pico)+#if MIN_VERSION_base(4,7,0)+import Data.Fixed (Fixed(MkFixed))+#else+import Unsafe.Coerce (unsafeCoerce)+#endif -- | Like 'E.mask', but backported to base before version 4.3.0. --@@ -42,4 +61,25 @@ (<>) :: Monoid m => m -> m -> m (<>) = mappend {-# INLINE (<>) #-}+#endif++toByteString :: Builder -> ByteString+toByteString x = toStrict (toLazyByteString x)++#if MIN_VERSION_base(4,7,0)++toPico :: Integer -> Pico+toPico = MkFixed++fromPico :: Pico -> Integer+fromPico (MkFixed i) = i++#else++toPico :: Integer -> Pico+toPico = unsafeCoerce++fromPico :: Pico -> Integer+fromPico = unsafeCoerce+ #endif
src/Database/PostgreSQL/Simple/Errors.hs view
@@ -55,6 +55,8 @@ -- ^ Name of violated constraint | CheckViolation ByteString ByteString -- ^ Relation name (usually table), constraint name+ | ExclusionViolation ByteString+ -- ^ Name of the exclusion violation constraint deriving (Show, Eq, Ord, Typeable) -- Default instance should be enough@@ -75,6 +77,7 @@ "23503" -> uncurry ForeignKeyViolation <$> parseMaybe parseQ2 msg "23505" -> UniqueViolation <$> parseMaybe parseQ1 msg "23514" -> uncurry CheckViolation <$> parseMaybe parseQ2 msg+ "23P01" -> ExclusionViolation <$> parseMaybe parseQ1 msg _ -> Nothing where msg = sqlErrorMsg e
src/Database/PostgreSQL/Simple/FromField.hs view
@@ -28,10 +28,10 @@ need accuracy, consider first converting data to a 'Scientific' or 'Rational' type, and then converting to a floating-point type. If you are defining your own 'Database.PostgreSQL.Simple.FromRow.FromRow' instances, this can be-acheived simply by+achieved simply by @'fromRational' '<$>' 'Database.PostgreSQL.Simple.FromRow.field'@, although-this idiom is additionally compatible with PostgreSQL's @numeric@ type.-If this is unacceptable, you may find+this idiom is additionally compatible with PostgreSQL's @int8@ and @numeric@+types. If this is unacceptable, you may find 'Database.PostgreSQL.Simple.FromRow.fieldWith' useful. Also note that while converting to a 'Double' through the 'Scientific' type@@ -112,10 +112,11 @@ #include "MachDeps.h" -import Control.Applicative ( (<|>), (<$>), pure, (*>) )+import Control.Applicative ( (<|>), (<$>), pure, (*>), (<*) ) import Control.Concurrent.MVar (MVar, newMVar) import Control.Exception (Exception) import qualified Data.Aeson as JSON+import qualified Data.Aeson.Parser as JSON (value') import Data.Attoparsec.ByteString.Char8 hiding (Result) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as B@@ -145,8 +146,8 @@ import qualified Data.Text.Lazy as LT import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI-import Data.UUID (UUID)-import qualified Data.UUID as UUID+import Data.UUID.Types (UUID)+import qualified Data.UUID.Types as UUID import Data.Scientific (Scientific) import GHC.Real (infinity, notANumber) @@ -217,7 +218,7 @@ typeInfo :: Field -> Conversion TypeInfo typeInfo Field{..} = Conversion $ \conn -> do- Ok <$> (getTypeInfo conn =<< PQ.ftype result column)+ Ok <$> (getTypeInfo conn typeOid) typeInfoByOid :: PQ.Oid -> Conversion TypeInfo typeInfoByOid oid = Conversion $ \conn -> do@@ -334,15 +335,15 @@ fromField = atto ok pg_double where ok = $(mkCompats [TI.float4,TI.float8,TI.int2,TI.int4]) --- | int2, int4, float4, float8, numeric+-- | int2, int4, int8, float4, float8, numeric instance FromField (Ratio Integer) where fromField = atto ok pg_rational- where ok = $(mkCompats [TI.float4,TI.float8,TI.int2,TI.int4,TI.numeric])+ where ok = $(mkCompats [TI.float4,TI.float8,TI.int2,TI.int4,TI.int8,TI.numeric]) --- | int2, int4, float4, float8, numeric+-- | int2, int4, int8, float4, float8, numeric instance FromField Scientific where fromField = atto ok rational- where ok = $(mkCompats [TI.float4,TI.float8,TI.int2,TI.int4,TI.numeric])+ where ok = $(mkCompats [TI.float4,TI.float8,TI.int2,TI.int4,TI.int8,TI.numeric]) unBinary :: Binary t -> t unBinary (Binary x) = x@@ -545,13 +546,7 @@ else case mbs of Nothing -> returnError UnexpectedNull f "" Just bs ->-#if MIN_VERSION_aeson(0,6,3)- case JSON.eitherDecodeStrict' bs of-#elif MIN_VERSION_bytestring(0,10,0)- case JSON.eitherDecode' $ LB.fromStrict bs of-#else- case JSON.eitherDecode' $ LB.fromChunks [bs] of-#endif+ case parseOnly (JSON.value' <* endOfInput) bs of Left err -> returnError ConversionFailed f err Right val -> pure val
src/Database/PostgreSQL/Simple/HStore/Implementation.hs view
@@ -15,12 +15,11 @@ module Database.PostgreSQL.Simple.HStore.Implementation where import Control.Applicative-import Blaze.ByteString.Builder as Blaze- ( Builder, toLazyByteString, copyByteString )-import Blaze.ByteString.Builder.Char8 (fromChar) import qualified Data.Attoparsec.ByteString as P import qualified Data.Attoparsec.ByteString.Char8 as P (isSpace_w8) import qualified Data.ByteString as BS+import Data.ByteString.Builder (Builder, byteString, char8)+import qualified Data.ByteString.Builder as BU import Data.ByteString.Internal (c2w, w2c) import qualified Data.ByteString.Lazy as BL #if !MIN_VERSION_bytestring(0,10,0)@@ -58,7 +57,7 @@ toLazyByteString :: HStoreBuilder -> BL.ByteString toLazyByteString x = case x of Empty -> BL.empty- Comma x -> Blaze.toLazyByteString x+ Comma x -> BU.toLazyByteString x instance Monoid HStoreBuilder where mempty = Empty@@ -66,7 +65,7 @@ mappend (Comma a) x = Comma (a `mappend` case x of Empty -> mempty- Comma b -> fromChar ',' `mappend` b)+ Comma b -> char8 ',' `mappend` b) class ToHStoreText a where toHStoreText :: a -> HStoreText@@ -95,24 +94,24 @@ escapeAppend = loop where loop (BS.break quoteNeeded -> (a,b)) rest- = copyByteString a `mappend`+ = byteString a `mappend` case BS.uncons b of Nothing -> rest Just (c,d) -> quoteChar c `mappend` loop d rest quoteNeeded c = c == c2w '\"' || c == c2w '\\' quoteChar c- | c == c2w '\"' = copyByteString "\\\""- | otherwise = copyByteString "\\\\"+ | c == c2w '\"' = byteString "\\\""+ | otherwise = byteString "\\\\" hstore :: (ToHStoreText a, ToHStoreText b) => a -> b -> HStoreBuilder hstore (toHStoreText -> (HStoreText key)) (toHStoreText -> (HStoreText val)) =- Comma (fromChar '"' `mappend` key `mappend` copyByteString "\"=>\""- `mappend` val `mappend` fromChar '"')+ Comma (char8 '"' `mappend` key `mappend` byteString "\"=>\""+ `mappend` val `mappend` char8 '"') instance ToField HStoreBuilder where toField Empty = toField (BS.empty)- toField (Comma x) = toField (Blaze.toLazyByteString x)+ toField (Comma x) = toField (BU.toLazyByteString x) newtype HStoreList = HStoreList {fromHStoreList :: [(Text,Text)]} deriving (Typeable, Show)
src/Database/PostgreSQL/Simple/Internal.hs view
@@ -20,8 +20,6 @@ module Database.PostgreSQL.Simple.Internal where -import Blaze.ByteString.Builder- ( Builder, fromByteString, toByteString ) import Control.Applicative import Control.Exception import Control.Concurrent.MVar@@ -29,6 +27,7 @@ import Data.ByteString(ByteString) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as B8+import Data.ByteString.Builder ( Builder, byteString ) import Data.Char (ord) import Data.Int (Int64) import qualified Data.IntMap as IntMap@@ -43,6 +42,7 @@ import Database.PostgreSQL.LibPQ(Oid(..)) import qualified Database.PostgreSQL.LibPQ as PQ import Database.PostgreSQL.LibPQ(ExecStatus(..))+import Database.PostgreSQL.Simple.Compat ( toByteString ) import Database.PostgreSQL.Simple.Ok import Database.PostgreSQL.Simple.ToField (Action(..), inQuotes) import Database.PostgreSQL.Simple.Types (Query(..))@@ -75,8 +75,11 @@ connectionHandle :: {-# UNPACK #-} !(MVar PQ.Connection) , connectionObjects :: {-# UNPACK #-} !(MVar TypeInfoCache) , connectionTempNameCounter :: {-# UNPACK #-} !(IORef Int64)- }+ } deriving (Typeable) +instance Eq Connection where+ x == y = connectionHandle x == connectionHandle y+ data SqlError = SqlError { sqlState :: ByteString , sqlExecStatus :: ExecStatus@@ -206,9 +209,9 @@ -- SSL/TLS will typically "just work" if your postgresql server supports or -- requires it. However, note that libpq is trivially vulnerable to a MITM -- attack without setting additional SSL parameters in the connection string.--- In particular, @sslmode@ needs to set be @require@, @verify-ca@, or--- @verify-full@ to perform certificate validation. When @sslmode@ is--- @require@, then you will also need to have a @sslrootcert@ file,+-- In particular, @sslmode@ needs to be set to @require@, @verify-ca@, or+-- @verify-full@ in order to perform certificate validation. When @sslmode@+-- is @require@, then you will also need to specify a @sslrootcert@ file, -- otherwise no validation of the server's identity will be performed. -- Client authentication via certificates is also possible via the -- @sslcert@ and @sslkey@ parameters.@@ -225,8 +228,8 @@ let wconn = Connection{..} version <- PQ.serverVersion conn let settings- | version < 80200 = "SET datestyle TO ISO"- | otherwise = "SET standard_conforming_strings TO on;SET datestyle TO ISO"+ | version < 80200 = "SET datestyle TO ISO;SET client_encoding TO UTF8"+ | otherwise = "SET datestyle TO ISO;SET client_encoding TO UTF8;SET standard_conforming_strings TO on" _ <- execute_ wconn settings return wconn _ -> do@@ -538,7 +541,7 @@ -- | Quote bytestring or throw 'FormatError' quote :: Query -> [Action] -> Either ByteString ByteString -> Builder-quote q xs = either (fmtErrorBs q xs) (inQuotes . fromByteString)+quote q xs = either (fmtErrorBs q xs) (inQuotes . byteString) buildAction :: Connection -- ^ Connection for string escaping -> Query -- ^ Query for message error@@ -549,7 +552,7 @@ buildAction conn q xs (Escape s) = quote q xs <$> escapeStringConn conn s buildAction conn q xs (EscapeByteA s) = quote q xs <$> escapeByteaConn conn s buildAction conn q xs (EscapeIdentifier s) =- either (fmtErrorBs q xs) fromByteString <$> escapeIdentifier conn s+ either (fmtErrorBs q xs) byteString <$> escapeIdentifier conn s buildAction conn q xs (Many ys) = mconcat <$> mapM (buildAction conn q xs) ys
src/Database/PostgreSQL/Simple/LargeObjects.hs view
@@ -14,7 +14,7 @@ -- database transaction, so if you are interested in using anything beyond -- 'loCreat', 'loCreate', and 'loUnlink', you will need to run the entire -- sequence of functions in a transaction. As 'loImport' and 'loExport'--- are simply C functions that call 'loCreat', 'loOpen', 'loRead', and +-- are simply C functions that call 'loCreat', 'loOpen', 'loRead', and -- 'loWrite', and do not perform any transaction handling themselves, -- they also need to be wrapped in an explicit transaction. --
+ src/Database/PostgreSQL/Simple/Range.hs view
@@ -0,0 +1,313 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}++------------------------------------------------------------------------------+-- |+-- Module: Database.PostgreSQL.Simple.Range+-- Copyright: (c) 2014-2015 Leonid Onokhov+-- (c) 2014-2015 Leon P Smith+-- License: BSD3+-- Maintainer: Leon P Smith <leon@melding-monads.com>+--+------------------------------------------------------------------------------++module Database.PostgreSQL.Simple.Range+ ( RangeBound(..)+ , PGRange(..)+ , empty+ , isEmpty, isEmptyBy+ , contains, containsBy+ ) where++import Control.Applicative hiding (empty)+import Data.Attoparsec.ByteString.Char8 (Parser, parseOnly)+import qualified Data.Attoparsec.ByteString.Char8 as A+import qualified Data.ByteString as B+import Data.ByteString.Builder+ ( Builder, byteString, lazyByteString, char8+ , intDec, int8Dec, int16Dec, int32Dec, int64Dec, integerDec+ , wordDec, word8Dec, word16Dec, word32Dec, word64Dec+ , doubleDec, floatDec )+import Data.Int (Int16, Int32, Int64,+ Int8)+import Data.Function (on)+import Data.Monoid (mempty)+import Data.Scientific (Scientific)+import qualified Data.Text.Lazy.Builder as LT+import qualified Data.Text.Lazy.Encoding as LT+import Data.Time (Day, LocalTime,+ NominalDiffTime,+ TimeOfDay, UTCTime,+ ZonedTime,+ zonedTimeToUTC)+import Data.Typeable (Typeable)+import Data.Word (Word, Word16, Word32,+ Word64, Word8)++import Database.PostgreSQL.Simple.Compat (scientificBuilder, (<>), toByteString)+import Database.PostgreSQL.Simple.FromField+import Database.PostgreSQL.Simple.Time+ hiding (PosInfinity, NegInfinity)+-- import qualified Database.PostgreSQL.Simple.Time as Time+import Database.PostgreSQL.Simple.ToField++-- | Represents boundary of a range+data RangeBound a = NegInfinity+ | Inclusive !a+ | Exclusive !a+ | PosInfinity+ deriving (Show, Typeable, Eq, Functor)++-- | Generic range type+data PGRange a = PGRange !(RangeBound a) !(RangeBound a)+ deriving (Show, Typeable, Functor)++empty :: PGRange a+empty = PGRange PosInfinity NegInfinity++instance Ord a => Eq (PGRange a) where+ x == y = eq x y || (isEmpty x && isEmpty y)+ where eq (PGRange a m) (PGRange b n) = a == b && m == n++isEmptyBy :: (a -> a -> Ordering) -> PGRange a -> Bool+isEmptyBy cmp v =+ case v of+ (PGRange PosInfinity _) -> True+ (PGRange _ NegInfinity) -> True+ (PGRange NegInfinity _) -> False+ (PGRange _ PosInfinity) -> False+ (PGRange (Inclusive x) (Inclusive y)) -> cmp x y == GT+ (PGRange (Inclusive x) (Exclusive y)) -> cmp x y /= LT+ (PGRange (Exclusive x) (Inclusive y)) -> cmp x y /= LT+ (PGRange (Exclusive x) (Exclusive y)) -> cmp x y /= LT++-- | Is a range empty? If this returns 'True', then the 'contains'+-- predicate will always return 'False'. However, if this returns+-- 'False', it is not necessarily true that there exists a point for+-- which 'contains' returns 'True'.+-- Consider @'PGRange' ('Excludes' 2) ('Excludes' 3) :: PGRange Int@,+-- for example.+isEmpty :: Ord a => PGRange a -> Bool+isEmpty = isEmptyBy compare+++-- | Does a range contain a given point? Note that in some cases, this may+-- not correspond exactly with a server-side computation. Consider @UTCTime@+-- for example, which has a resolution of a picosecond, whereas postgresql's+-- @timestamptz@ types have a resolution of a microsecond. Putting such+-- Haskell values into the database will result in them being rounded, which+-- can change the value of the containment predicate.++contains :: Ord a => PGRange a -> (a -> Bool)+contains = containsBy compare++containsBy :: (a -> a -> Ordering) -> PGRange a -> (a -> Bool)+containsBy cmp rng x =+ case rng of+ PGRange _lb NegInfinity -> False+ PGRange lb ub -> checkLB lb x && checkUB ub x+ where+ checkLB lb x =+ case lb of+ NegInfinity -> True+ PosInfinity -> False+ Inclusive a -> cmp a x /= GT+ Exclusive a -> cmp a x == LT++ checkUB ub x =+ case ub of+ NegInfinity -> False+ PosInfinity -> True+ Inclusive z -> cmp x z /= GT+ Exclusive z -> cmp x z == LT++lowerBound :: Parser (a -> RangeBound a)+lowerBound = (A.char '(' *> pure Exclusive) <|> (A.char '[' *> pure Inclusive)+{-# INLINE lowerBound #-}++upperBound :: Parser (a -> RangeBound a)+upperBound = (A.char ')' *> pure Exclusive) <|> (A.char ']' *> pure Inclusive)+{-# INLINE upperBound #-}++-- | Generic range parser+pgrange :: Parser (RangeBound B.ByteString, RangeBound B.ByteString)+pgrange = do+ lb <- lowerBound+ v1 <- (A.char ',' *> "") <|> (rangeElem (==',') <* A.char ',')+ v2 <- rangeElem $ \c -> c == ')' || c == ']'+ ub <- upperBound+ A.endOfInput+ let low = if B.null v1 then NegInfinity else lb v1+ up = if B.null v2 then PosInfinity else ub v2+ return (low, up)++rangeElem :: (Char -> Bool) -> Parser B.ByteString+rangeElem end = (A.char '"' *> doubleQuoted)+ <|> A.takeTill end+{-# INLINE rangeElem #-}++-- | Simple double quoted value parser+doubleQuoted :: Parser B.ByteString+doubleQuoted = toByteString <$> go mempty+ where+ go acc = do+ h <- byteString <$> A.takeTill (\c -> c == '\\' || c == '"')+ let rest = do+ start <- A.anyChar+ case start of+ '\\' -> do+ c <- A.anyChar+ go (acc <> h <> char8 c)+ '"' -> (A.char '"' *> go (acc <> h <> char8 '"'))+ <|> pure (acc <> h)+ _ -> error "impossible in doubleQuoted"+ rest++rangeToBuilder :: Ord a => (a -> Builder) -> PGRange a -> Builder+rangeToBuilder = rangeToBuilderBy compare++-- | Generic range to builder for plain values+rangeToBuilderBy :: (a -> a -> Ordering) -> (a -> Builder) -> PGRange a -> Builder+rangeToBuilderBy cmp f x =+ if isEmptyBy cmp x+ then byteString "'empty'"+ else let (PGRange a b) = x+ in buildLB a <> buildUB b+ where+ buildLB NegInfinity = byteString "'[,"+ buildLB (Inclusive v) = byteString "'[\"" <> f v <> byteString "\","+ buildLB (Exclusive v) = byteString "'(\"" <> f v <> byteString "\","+ buildLB PosInfinity = error "impossible in rangeToBuilder"++ buildUB NegInfinity = error "impossible in rangeToBuilder"+ buildUB (Inclusive v) = char8 '"' <> f v <> byteString "\"]'"+ buildUB (Exclusive v) = char8 '"' <> f v <> byteString "\")'"+ buildUB PosInfinity = byteString "]'"+{-# INLINE rangeToBuilder #-}+++instance (FromField a, Typeable a) => FromField (PGRange a) where+ fromField f mdat = do+ info <- typeInfo f+ case info of+ Range{} ->+ let f' = f { typeOid = typoid (rngsubtype info) }+ in case mdat of+ Nothing -> returnError UnexpectedNull f ""+ Just "empty" -> pure $ empty+ Just bs ->+ let parseIt NegInfinity = pure NegInfinity+ parseIt (Inclusive v) = Inclusive <$> fromField f' (Just v)+ parseIt (Exclusive v) = Exclusive <$> fromField f' (Just v)+ parseIt PosInfinity = pure PosInfinity+ in case parseOnly pgrange bs of+ Left e -> returnError ConversionFailed f e+ Right (lb,ub) -> PGRange <$> parseIt lb <*> parseIt ub+ _ -> returnError Incompatible f ""+++instance ToField (PGRange Int8) where+ toField = Plain . rangeToBuilder int8Dec+ {-# INLINE toField #-}++instance ToField (PGRange Int16) where+ toField = Plain . rangeToBuilder int16Dec+ {-# INLINE toField #-}++instance ToField (PGRange Int32) where+ toField = Plain . rangeToBuilder int32Dec+ {-# INLINE toField #-}++instance ToField (PGRange Int) where+ toField = Plain . rangeToBuilder intDec+ {-# INLINE toField #-}++instance ToField (PGRange Int64) where+ toField = Plain . rangeToBuilder int64Dec+ {-# INLINE toField #-}++instance ToField (PGRange Integer) where+ toField = Plain . rangeToBuilder integerDec+ {-# INLINE toField #-}++instance ToField (PGRange Word8) where+ toField = Plain . rangeToBuilder word8Dec+ {-# INLINE toField #-}++instance ToField (PGRange Word16) where+ toField = Plain . rangeToBuilder word16Dec+ {-# INLINE toField #-}++instance ToField (PGRange Word32) where+ toField = Plain . rangeToBuilder word32Dec+ {-# INLINE toField #-}++instance ToField (PGRange Word) where+ toField = Plain . rangeToBuilder wordDec+ {-# INLINE toField #-}++instance ToField (PGRange Word64) where+ toField = Plain . rangeToBuilder word64Dec+ {-# INLINE toField #-}++instance ToField (PGRange Float) where+ toField = Plain . rangeToBuilder floatDec+ {-# INLINE toField #-}++instance ToField (PGRange Double) where+ toField = Plain . rangeToBuilder doubleDec+ {-# INLINE toField #-}++instance ToField (PGRange Scientific) where+ toField = Plain . rangeToBuilder f+ where+ f = lazyByteString . LT.encodeUtf8 . LT.toLazyText . scientificBuilder+ {-# INLINE toField #-}++instance ToField (PGRange UTCTime) where+ toField = Plain . rangeToBuilder utcTimeToBuilder+ {-# INLINE toField #-}++instance ToField (PGRange ZonedTime) where+ toField = Plain . rangeToBuilderBy cmpZonedTime zonedTimeToBuilder+ {-# INLINE toField #-}++cmpZonedTime :: ZonedTime -> ZonedTime -> Ordering+cmpZonedTime = compare `on` zonedTimeToUTC -- FIXME: optimize++instance ToField (PGRange LocalTime) where+ toField = Plain . rangeToBuilder localTimeToBuilder+ {-# INLINE toField #-}++instance ToField (PGRange Day) where+ toField = Plain . rangeToBuilder dayToBuilder+ {-# INLINE toField #-}++instance ToField (PGRange TimeOfDay) where+ toField = Plain . rangeToBuilder timeOfDayToBuilder+ {-# INLINE toField #-}++instance ToField (PGRange UTCTimestamp) where+ toField = Plain . rangeToBuilder utcTimestampToBuilder+ {-# INLINE toField #-}++instance ToField (PGRange ZonedTimestamp) where+ toField = Plain . rangeToBuilderBy cmpZonedTimestamp zonedTimestampToBuilder+ {-# INLINE toField #-}++cmpZonedTimestamp :: ZonedTimestamp -> ZonedTimestamp -> Ordering+cmpZonedTimestamp = compare `on` (zonedTimeToUTC <$>)++instance ToField (PGRange LocalTimestamp) where+ toField = Plain . rangeToBuilder localTimestampToBuilder+ {-# INLINE toField #-}++instance ToField (PGRange Date) where+ toField = Plain . rangeToBuilder dateToBuilder+ {-# INLINE toField #-}++instance ToField (PGRange NominalDiffTime) where+ toField = Plain . rangeToBuilder nominalDiffTimeToBuilder+ {-# INLINE toField #-}
src/Database/PostgreSQL/Simple/SqlQQ.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE TemplateHaskell #-} ------------------------------------------------------------------------------ -- | -- Module: Database.PostgreSQL.Simple.SqlQQ@@ -9,15 +10,16 @@ ------------------------------------------------------------------------------ module Database.PostgreSQL.Simple.SqlQQ (sql) where-+import Database.PostgreSQL.Simple.Types (Query) import Language.Haskell.TH import Language.Haskell.TH.Quote import Data.Char+import Data.String -- | 'sql' is a quasiquoter that eases the syntactic burden -- of writing big sql statements in Haskell source code. For example: ----- > {-# LANGUAGE OverloadedStrings, QuasiQuotes #-}+-- > {-# LANGUAGE QuasiQuotes #-} -- > -- > query conn [sql| SELECT column_a, column_b -- > FROM table1 NATURAL JOIN table2@@ -27,10 +29,10 @@ -- > LIMIT 100 |] -- > (beginTime,endTime,string) ----- This quasiquoter attempts to mimimize whitespace; otherwise the--- above query would consist of approximately half whitespace when sent--- to the database backend. It also recognizes and strips out standard--- sql comments "--".+-- This quasiquoter returns a literal string expression of type 'Query',+-- and attempts to mimimize whitespace; otherwise the above query would+-- consist of approximately half whitespace when sent to the database+-- backend. It also recognizes and strips out standard sql comments "--". -- -- The implementation of the whitespace reducer is currently incomplete. -- Thus it can mess up your syntax in cases where whitespace should be@@ -60,7 +62,7 @@ } sqlExp :: String -> Q Exp-sqlExp = stringE . minimizeSpace+sqlExp = appE [| fromString :: String -> Query |] . stringE . minimizeSpace minimizeSpace :: String -> String minimizeSpace = drop 1 . reduceSpace
src/Database/PostgreSQL/Simple/Time/Implementation.hs view
@@ -1,51 +1,43 @@ ------------------------------------------------------------------------------ -- | -- Module: Database.PostgreSQL.Simple.Time.Implementation--- Copyright: (c) 2012 Leon P Smith+-- Copyright: (c) 2012-2015 Leon P Smith -- License: BSD3 -- Maintainer: Leon P Smith <leon@melding-monads.com> -- Stability: experimental -- ------------------------------------------------------------------------------ -{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveDataTypeable, DeriveFunctor #-} module Database.PostgreSQL.Simple.Time.Implementation where -import Prelude hiding (take, (++))-import Blaze.ByteString.Builder(Builder, fromByteString)-import Blaze.ByteString.Builder.Char8(fromChar)-import Blaze.Text.Int(integral)+import Prelude hiding (take)+import Data.ByteString.Builder(Builder, byteString)+import Data.ByteString.Builder.Prim(primBounded) import Control.Arrow((***)) import Control.Applicative-import Control.Monad(when)-import Data.Bits((.&.)) import qualified Data.ByteString as B-import Data.ByteString.Internal (c2w, w2c) import Data.Time hiding (getTimeZone, getZonedTime) import Data.Typeable-import Data.Word(Word8)+import Data.Maybe (fromMaybe) import qualified Data.Attoparsec.ByteString.Char8 as A-import Data.Monoid(Monoid(..))-import Data.Fixed (Pico)-import Unsafe.Coerce--(++) :: Monoid a => a -> a -> a-(++) = mappend-infixr 5 +++import Database.PostgreSQL.Simple.Compat ((<>))+import qualified Database.PostgreSQL.Simple.Time.Internal.Parser as TP+import qualified Database.PostgreSQL.Simple.Time.Internal.Printer as TPP data Unbounded a = NegInfinity | Finite !a | PosInfinity- deriving (Eq, Ord, Typeable)+ deriving (Eq, Ord, Typeable, Functor) instance Show a => Show (Unbounded a) where showsPrec prec x rest = case x of- NegInfinity -> "-infinity" ++ rest+ NegInfinity -> "-infinity" <> rest Finite time -> showsPrec prec time rest- PosInfinity -> "infinity" ++ rest+ PosInfinity -> "infinity" <> rest instance Read a => Read (Unbounded a) where readsPrec prec = readParen False $ \str -> case str of@@ -92,160 +84,71 @@ <|> (Finite <$> getFinite) getDay :: A.Parser Day-getDay = do- yearStr <- A.takeWhile A.isDigit- when (B.length yearStr < 4) (fail "year must consist of at least 4 digits")-- let !year = toNum yearStr- _ <- A.char '-'- !month <- digits "month"- _ <- A.char '-'- day <- digits "day"-- case fromGregorianValid year month day of- Nothing -> fail "invalid date"- Just x -> return $! x+getDay = TP.day getDate :: A.Parser Date getDate = getUnbounded getDay -decimal :: Fractional a => B.ByteString -> a-decimal str = toNum str / 10^(B.length str)-{-# INLINE decimal #-}- getTimeOfDay :: A.Parser TimeOfDay-getTimeOfDay = do- !hour <- digits "hours"- _ <- A.char ':'- minute <- digits "minutes"- _ <- A.char ':'- second <- digits "seconds"- subsec <- (A.char '.' *> (decimal <$> A.takeWhile1 A.isDigit)) <|> return 0-- let !picos' = second + subsec-- case makeTimeOfDayValid hour minute picos' of- Nothing -> fail "invalid time of day"- Just x -> return $! x+getTimeOfDay = TP.timeOfDay getLocalTime :: A.Parser LocalTime-getLocalTime = LocalTime <$> getDay <*> (A.char ' ' *> getTimeOfDay)+getLocalTime = TP.localTime getLocalTimestamp :: A.Parser LocalTimestamp getLocalTimestamp = getUnbounded getLocalTime getTimeZone :: A.Parser TimeZone-getTimeZone = do- !sign <- A.satisfy (\c -> c == '+' || c == '-')- !hours <- digits "timezone"- !mins <- (A.char ':' *> digits "timezone minutes") <|> pure 0- let !absset = 60 * hours + mins- !offset = if sign == '+' then absset else -absset- return $! minutesToTimeZone offset+getTimeZone = fromMaybe utc <$> TP.timeZone type TimeZoneHMS = (Int,Int,Int) getTimeZoneHMS :: A.Parser TimeZoneHMS-getTimeZoneHMS = do- !sign <- A.satisfy (\c -> c == '+' || c == '-')- !hours <- digits "timezone"- !mins <- (A.char ':' *> digits "timezone minutes") <|> pure 0- !secs <- (A.char ':' *> digits "timezone seconds") <|> pure 0- if sign == '+'- then return $! (hours, mins, secs)- else return $! (\ !h !m !s -> (h,m,s)) (-hours) (-mins) (-secs)+getTimeZoneHMS = munge <$> TP.timeZoneHMS+ where+ munge Nothing = (0,0,0)+ munge (Just (TP.UTCOffsetHMS h m s)) = (h,m,s) localToUTCTimeOfDayHMS :: TimeZoneHMS -> TimeOfDay -> (Integer, TimeOfDay)-localToUTCTimeOfDayHMS (dh, dm, ds) (TimeOfDay h m s) =- (\ !a !b -> (a,b)) dday (TimeOfDay h'' m'' s'')- where- s' = s - fromIntegral ds- (!s'', m')- | s' < 0 = (s' + 60, m - dm - 1)- | s' >= 60 = (s' - 60, m - dm + 1)- | otherwise = (s' , m - dm )- (!m'', h')- | m' < 0 = (m' + 60, h - dh - 1)- | m' >= 60 = (m' - 60, h - dh + 1)- | otherwise = (m' , h - dh )- (!h'', dday)- | h' < 0 = (h' + 24, -1)- | h' >= 24 = (h' - 24, 1)- | otherwise = (h' , 0)+localToUTCTimeOfDayHMS (dh, dm, ds) tod =+ TP.localToUTCTimeOfDayHMS (TP.UTCOffsetHMS dh dm ds) tod getZonedTime :: A.Parser ZonedTime-getZonedTime = ZonedTime <$> getLocalTime <*> getTimeZone+getZonedTime = TP.zonedTime getZonedTimestamp :: A.Parser ZonedTimestamp getZonedTimestamp = getUnbounded getZonedTime getUTCTime :: A.Parser UTCTime-getUTCTime = do- day <- getDay- _ <- A.char ' '- time <- getTimeOfDay- zone <- getTimeZoneHMS- let !(dayDelta,time') = localToUTCTimeOfDayHMS zone time- let !day' = addDays dayDelta day- let !time'' = timeOfDayToTime time'- return $! UTCTime day' time''+getUTCTime = TP.utcTime getUTCTimestamp :: A.Parser UTCTimestamp getUTCTimestamp = getUnbounded getUTCTime -toNum :: Num n => B.ByteString -> n-toNum = B.foldl' (\a c -> 10*a + digit c) 0-{-# INLINE toNum #-}--digit :: Num n => Word8 -> n-digit c = fromIntegral (c .&. 0x0f)-{-# INLINE digit #-}--digits :: Num n => String -> A.Parser n-digits msg = do- x <- A.anyChar- y <- A.anyChar- if A.isDigit x && A.isDigit y- then return $! (10 * digit (c2w x) + digit (c2w y))- else fail (msg ++ " is not 2 digits")-{-# INLINE digits #-}- dayToBuilder :: Day -> Builder-dayToBuilder (toGregorian -> (y,m,d)) = do- pad4 y ++ fromChar '-' ++ pad2 m ++ fromChar '-' ++ pad2 d+dayToBuilder = primBounded TPP.day timeOfDayToBuilder :: TimeOfDay -> Builder-timeOfDayToBuilder (TimeOfDay h m s) = do- pad2 h ++ fromChar ':' ++ pad2 m ++ fromChar ':' ++ showSeconds s+timeOfDayToBuilder = primBounded TPP.timeOfDay timeZoneToBuilder :: TimeZone -> Builder-timeZoneToBuilder tz- | m == 0 = sign h ++ pad2 (abs h)- | otherwise = sign h ++ pad2 (abs h) ++ fromChar ':' ++ pad2 (abs m)- where- (h,m) = timeZoneMinutes tz `quotRem` 60- sign h | h >= 0 = fromChar '+'- | otherwise = fromChar '-'+timeZoneToBuilder = primBounded TPP.timeZone utcTimeToBuilder :: UTCTime -> Builder-utcTimeToBuilder (UTCTime day time) =- dayToBuilder day ++ fromChar ' '- ++ timeOfDayToBuilder (timeToTimeOfDay time) ++ fromByteString "+00"+utcTimeToBuilder = primBounded TPP.utcTime zonedTimeToBuilder :: ZonedTime -> Builder-zonedTimeToBuilder (ZonedTime localTime tz) =- localTimeToBuilder localTime ++ timeZoneToBuilder tz+zonedTimeToBuilder = primBounded TPP.zonedTime localTimeToBuilder :: LocalTime -> Builder-localTimeToBuilder (LocalTime day tod) =- dayToBuilder day ++ fromChar ' ' ++ timeOfDayToBuilder tod+localTimeToBuilder = primBounded TPP.localTime unboundedToBuilder :: (a -> Builder) -> (Unbounded a -> Builder) unboundedToBuilder finiteToBuilder unbounded = case unbounded of- NegInfinity -> fromByteString "-infinity"+ NegInfinity -> byteString "-infinity" Finite a -> finiteToBuilder a- PosInfinity -> fromByteString "infinity"+ PosInfinity -> byteString "infinity" utcTimestampToBuilder :: UTCTimestamp -> Builder utcTimestampToBuilder = unboundedToBuilder utcTimeToBuilder@@ -260,64 +163,4 @@ dateToBuilder = unboundedToBuilder dayToBuilder nominalDiffTimeToBuilder :: NominalDiffTime -> Builder-nominalDiffTimeToBuilder xyz- | yz < 500000 = sign ++ integral x- | otherwise = sign ++ integral x ++ fromChar '.' ++ showD6 y- where- -- A kludge to work around the fact that Data.Fixed isn't very fast and- -- doesn't give me access to the MkFixed constructor.- sign = if xyz >= 0 then mempty else fromChar '-'- (x,yz) = ((unsafeCoerce (abs xyz) :: Integer) + 500000) `quotRem` 1000000000000- (fromIntegral -> y, _z) = yz `quotRem` 1000000--showSeconds :: Pico -> Builder-showSeconds xyz- | yz == 0 = pad2 x- | z == 0 = pad2 x ++ fromChar '.' ++ showD6 y- | otherwise = pad2 x ++ fromChar '.' ++ pad6 y ++ showD6 z- where- -- A kludge to work around the fact that Data.Fixed isn't very fast and- -- doesn't give me access to the MkFixed constructor.- (x_,yz) = (unsafeCoerce xyz :: Integer) `quotRem` 1000000000000- x = fromIntegral x_ :: Int- (fromIntegral -> y, fromIntegral -> z) = yz `quotRem` 1000000--pad6 :: Int -> Builder-pad6 xy = let (x,y) = xy `quotRem` 1000- in pad3 x ++ pad3 y--showD6 :: Int -> Builder-showD6 xy = case xy `quotRem` 1000 of- (x,0) -> showD3 x- (x,y) -> pad3 x ++ showD3 y--pad3 :: Int -> Builder-pad3 abc = let (ab,c) = abc `quotRem` 10- (a,b) = ab `quotRem` 10- in p a ++ p b ++ p c--showD3 :: Int -> Builder-showD3 abc = case abc `quotRem` 100 of- (a, 0) -> p a- (a,bc) -> case bc `quotRem` 10 of- (b,0) -> p a ++ p b- (b,c) -> p a ++ p b ++ p c---- | p assumes its input is in the range [0..9]-p :: Integral n => n -> Builder-p n = fromChar (w2c (fromIntegral (n + 48)))-{-# INLINE p #-}---- | pad2 assumes its input is in the range [0..99]-pad2 :: Integral n => n -> Builder-pad2 n = let (a,b) = n `quotRem` 10 in p a ++ p b-{-# INLINE pad2 #-}---- | pad4 assumes its input is positive-pad4 :: (Integral n, Show n) => n -> Builder-pad4 abcd | abcd >= 10000 = integral abcd- | otherwise = p a ++ p b ++ p c ++ p d- where (ab,cd) = abcd `quotRem` 100- (a,b) = ab `quotRem` 10- (c,d) = cd `quotRem` 10-{-# INLINE pad4 #-}+nominalDiffTimeToBuilder = TPP.nominalDiffTime
+ src/Database/PostgreSQL/Simple/Time/Internal/Parser.hs view
@@ -0,0 +1,192 @@+{-# LANGUAGE BangPatterns, ScopedTypeVariables #-}++-- |+-- Module: Database.PostgreSQL.Simple.Time.Internal.Parser+-- Copyright: (c) 2012-2015 Leon P Smith+-- (c) 2015 Bryan O'Sullivan+-- License: BSD3+-- Maintainer: Leon P Smith <leon@melding-monads.com>+-- Stability: experimental+--+-- Parsers for parsing dates and times.++module Database.PostgreSQL.Simple.Time.Internal.Parser+ (+ day+ , localTime+ , timeOfDay+ , timeZone+ , UTCOffsetHMS(..)+ , timeZoneHMS+ , localToUTCTimeOfDayHMS+ , utcTime+ , zonedTime+ ) where++import Control.Applicative ((<$>), (<*>), (<*), (*>))+import Database.PostgreSQL.Simple.Compat (toPico)+import Data.Attoparsec.ByteString.Char8 as A+import Data.Bits ((.&.))+import Data.Char (ord)+import Data.Fixed (Pico)+import Data.Int (Int64)+import Data.Maybe (fromMaybe)+import Data.Time.Calendar (Day, fromGregorianValid, addDays)+import Data.Time.Clock (UTCTime(..))+import qualified Data.ByteString.Char8 as B8+import qualified Data.Time.LocalTime as Local++-- | Parse a date of the form @YYYY-MM-DD@.+day :: Parser Day+day = do+ y <- decimal <* char '-'+ m <- twoDigits <* char '-'+ d <- twoDigits+ maybe (fail "invalid date") return (fromGregorianValid y m d)++-- | Parse a two-digit integer (e.g. day of month, hour).+twoDigits :: Parser Int+twoDigits = do+ a <- digit+ b <- digit+ let c2d c = ord c .&. 15+ return $! c2d a * 10 + c2d b++-- | Parse a time of the form @HH:MM:SS[.SSS]@.+timeOfDay :: Parser Local.TimeOfDay+timeOfDay = do+ h <- twoDigits <* char ':'+ m <- twoDigits <* char ':'+ s <- seconds+ if h < 24 && m < 60 && s <= 60+ then return (Local.TimeOfDay h m s)+ else fail "invalid time"++-- | Parse a count of seconds, with the integer part being two digits+-- long.+seconds :: Parser Pico+seconds = do+ real <- twoDigits+ mc <- peekChar+ case mc of+ Just '.' -> do+ t <- anyChar *> takeWhile1 isDigit+ return $! parsePicos (fromIntegral real) t+ _ -> return $! fromIntegral real+ where+ parsePicos :: Int64 -> B8.ByteString -> Pico+ parsePicos a0 t = toPico (fromIntegral (t' * 10^n))+ where n = max 0 (12 - B8.length t)+ t' = B8.foldl' (\a c -> 10 * a + fromIntegral (ord c .&. 15)) a0+ (B8.take 12 t)++-- | Parse a time zone, and return 'Nothing' if the offset from UTC is+-- zero. (This makes some speedups possible.)+timeZone :: Parser (Maybe Local.TimeZone)+timeZone = do+ ch <- satisfy $ \c -> c == '+' || c == '-' || c == 'Z'+ if ch == 'Z'+ then return Nothing+ else do+ h <- twoDigits+ mm <- peekChar+ m <- case mm of+ Just ':' -> anyChar *> twoDigits+ _ -> return 0+ let off | ch == '-' = negate off0+ | otherwise = off0+ off0 = h * 60 + m+ case undefined of+ _ | off == 0 ->+ return Nothing+ | h > 23 || m > 59 ->+ fail "invalid time zone offset"+ | otherwise ->+ let !tz = Local.minutesToTimeZone off+ in return (Just tz)++data UTCOffsetHMS = UTCOffsetHMS {-# UNPACK #-} !Int {-# UNPACK #-} !Int {-# UNPACK #-} !Int++-- | Parse a time zone, and return 'Nothing' if the offset from UTC is+-- zero. (This makes some speedups possible.)+timeZoneHMS :: Parser (Maybe UTCOffsetHMS)+timeZoneHMS = do+ ch <- satisfy $ \c -> c == '+' || c == '-' || c == 'Z'+ if ch == 'Z'+ then return Nothing+ else do+ h <- twoDigits+ m <- maybeTwoDigits+ s <- maybeTwoDigits+ case undefined of+ _ | h == 0 && m == 0 && s == 0 ->+ return Nothing+ | h > 23 || m >= 60 || s >= 60 ->+ fail "invalid time zone offset"+ | otherwise ->+ if ch == '+'+ then let !tz = UTCOffsetHMS h m s+ in return (Just tz)+ else let !tz = UTCOffsetHMS (-h) (-m) (-s)+ in return (Just tz)+ where+ maybeTwoDigits = do+ ch <- peekChar+ case ch of+ Just ':' -> anyChar *> twoDigits+ _ -> return 0++localToUTCTimeOfDayHMS :: UTCOffsetHMS -> Local.TimeOfDay -> (Integer, Local.TimeOfDay)+localToUTCTimeOfDayHMS (UTCOffsetHMS dh dm ds) (Local.TimeOfDay h m s) =+ (\ !a !b -> (a,b)) dday (Local.TimeOfDay h'' m'' s'')+ where+ s' = s - fromIntegral ds+ (!s'', m')+ | s' < 0 = (s' + 60, m - dm - 1)+ | s' >= 60 = (s' - 60, m - dm + 1)+ | otherwise = (s' , m - dm )+ (!m'', h')+ | m' < 0 = (m' + 60, h - dh - 1)+ | m' >= 60 = (m' - 60, h - dh + 1)+ | otherwise = (m' , h - dh )+ (!h'', dday)+ | h' < 0 = (h' + 24, -1)+ | h' >= 24 = (h' - 24, 1)+ | otherwise = (h' , 0)+++-- | Parse a date and time, of the form @YYYY-MM-DD HH:MM:SS@.+-- The space may be replaced with a @T@. The number of seconds may be+-- followed by a fractional component.+localTime :: Parser Local.LocalTime+localTime = Local.LocalTime <$> day <* daySep <*> timeOfDay+ where daySep = satisfy (\c -> c == ' ' || c == 'T')++-- | Behaves as 'zonedTime', but converts any time zone offset into a+-- UTC time.+utcTime :: Parser UTCTime+utcTime = do+ (Local.LocalTime d t) <- localTime+ mtz <- timeZoneHMS+ case mtz of+ Nothing -> let !tt = Local.timeOfDayToTime t+ in return (UTCTime d tt)+ Just tz -> let !(dd,t') = localToUTCTimeOfDayHMS tz t+ !d' = addDays dd d+ !tt = Local.timeOfDayToTime t'+ in return (UTCTime d' tt)++-- | Parse a date with time zone info. Acceptable formats:+--+-- @YYYY-MM-DD HH:MM:SS Z@+--+-- The first space may instead be a @T@, and the second space is+-- optional. The @Z@ represents UTC. The @Z@ may be replaced with a+-- time zone offset of the form @+0000@ or @-08:00@, where the first+-- two digits are hours, the @:@ is optional and the second two digits+-- (also optional) are minutes.+zonedTime :: Parser Local.ZonedTime+zonedTime = Local.ZonedTime <$> localTime <*> (fromMaybe utc <$> timeZone)++utc :: Local.TimeZone+utc = Local.TimeZone 0 False ""
+ src/Database/PostgreSQL/Simple/Time/Internal/Printer.hs view
@@ -0,0 +1,123 @@+{-# LANGUAGE BangPatterns, ViewPatterns #-}++------------------------------------------------------------------------------+-- Module: Database.PostgreSQL.Simple.Time.Internal.Printer+-- Copyright: (c) 2012-2015 Leon P Smith+-- License: BSD3+-- Maintainer: Leon P Smith <leon@melding-monads.com>+-- Stability: experimental+------------------------------------------------------------------------------++module Database.PostgreSQL.Simple.Time.Internal.Printer+ (+ day+ , timeOfDay+ , timeZone+ , utcTime+ , localTime+ , zonedTime+ , nominalDiffTime+ ) where++import Control.Arrow ((>>>))+import Data.ByteString.Builder (Builder, integerDec)+import Data.ByteString.Builder.Prim+ ( liftFixedToBounded, (>$<), (>*<)+ , BoundedPrim, primBounded, condB, emptyB, FixedPrim, char8, int32Dec)+import Data.Char ( chr )+import Data.Int ( Int32, Int64 )+import Data.Time+ ( UTCTime(..), ZonedTime(..), LocalTime(..), NominalDiffTime+ , Day, toGregorian, TimeOfDay(..), timeToTimeOfDay+ , TimeZone, timeZoneMinutes )+import Database.PostgreSQL.Simple.Compat ((<>), fromPico)+import Unsafe.Coerce (unsafeCoerce)++liftB :: FixedPrim a -> BoundedPrim a+liftB = liftFixedToBounded++digit :: FixedPrim Int+digit = (\x -> chr (x + 48)) >$< char8++digits2 :: FixedPrim Int+digits2 = (`quotRem` 10) >$< (digit >*< digit)++digits3 :: FixedPrim Int+digits3 = (`quotRem` 10) >$< (digits2 >*< digit)++digits4 :: FixedPrim Int+digits4 = (`quotRem` 10) >$< (digits3 >*< digit)++frac :: BoundedPrim Int64+frac = condB (== 0) emptyB ((,) '.' >$< (liftB char8 >*< trunc12))+ where+ trunc12 :: BoundedPrim Int64+ trunc12 = (`quotRem` 1000000) >$<+ condB (\(_,y) -> y == 0)+ (fst >$< trunc6)+ (liftB digits6 >*< trunc6)++ digitB = liftB digit++ digits6 = (fromIntegral >>> (`quotRem` 10)) >$< (digits5 >*< digit)+ digits5 = (`quotRem` 10) >$< (digits4 >*< digit)++ trunc6 = (fromIntegral >>> (`quotRem` 100000)) >$< (digitB >*< trunc5)+ trunc5 = condB (== 0) emptyB ((`quotRem` 10000) >$< (digitB >*< trunc4))+ trunc4 = condB (== 0) emptyB ((`quotRem` 1000) >$< (digitB >*< trunc3))+ trunc3 = condB (== 0) emptyB ((`quotRem` 100) >$< (digitB >*< trunc2))+ trunc2 = condB (== 0) emptyB ((`quotRem` 10) >$< (digitB >*< trunc1))+ trunc1 = condB (== 0) emptyB digitB+++year :: BoundedPrim Int32+year = condB (> 10000) int32Dec (checkBCE >$< liftB digits4)+ where+ checkBCE :: Int32 -> Int+ checkBCE y+ | y > 0 = fromIntegral y+ | otherwise = error msg++ msg = "Database.PostgreSQL.Simple.Time.Printer.year: years BCE not supported"++day :: BoundedPrim Day+day = toYMD >$< (year >*< liftB (char8 >*< digits2 >*< char8 >*< digits2))+ where+ toYMD (toGregorian -> (fromIntegral -> !y, !m,!d)) = (y,('-',(m,('-',d))))++timeOfDay :: BoundedPrim TimeOfDay+timeOfDay = f >$< (hh_mm_ >*< ss)+ where+ f (TimeOfDay h m s) = ((h,(':',(m,':'))),s)++ hh_mm_ = liftB (digits2 >*< char8 >*< digits2 >*< char8)++ ss = (\s -> fromIntegral (fromPico s) `quotRem` 1000000000000) >$<+ (liftB (fromIntegral >$< digits2) >*< frac)++timeZone :: BoundedPrim TimeZone+timeZone = ((`quotRem` 60) . timeZoneMinutes) >$< (liftB tzh >*< tzm)+ where+ f h = if h >= 0 then ('+', h) else (,) '-' $! (-h)++ tzh = f >$< (char8 >*< digits2)++ tzm = condB (==0) emptyB ((,) ':' >$< liftB (char8 >*< digits2))++utcTime :: BoundedPrim UTCTime+utcTime = f >$< (day >*< liftB char8 >*< timeOfDay >*< liftB char8)+ where f (UTCTime d (timeToTimeOfDay -> tod)) = (d,(' ',(tod,'Z')))++localTime :: BoundedPrim LocalTime+localTime = f >$< (day >*< liftB char8 >*< timeOfDay)+ where f (LocalTime d tod) = (d, (' ', tod))++zonedTime :: BoundedPrim ZonedTime+zonedTime = f >$< (localTime >*< timeZone)+ where f (ZonedTime lt tz) = (lt, tz)+++nominalDiffTime :: NominalDiffTime -> Builder+nominalDiffTime xy = integerDec x <> primBounded frac (abs (fromIntegral y))+ where+ (x,y) = fromPico (unsafeCoerce xy) `quotRem` 1000000000000
src/Database/PostgreSQL/Simple/ToField.hs view
@@ -22,11 +22,14 @@ , inQuotes ) where -import Blaze.ByteString.Builder (Builder, fromByteString, toByteString)-import Blaze.ByteString.Builder.Char8 (fromChar)-import Blaze.Text (integral, double, float) import qualified Data.Aeson as JSON-import Data.ByteString (ByteString)+import Data.ByteString (ByteString)+import Data.ByteString.Builder+ ( Builder, byteString, char8, stringUtf8+ , intDec, int8Dec, int16Dec, int32Dec, int64Dec, integerDec+ , wordDec, word8Dec, word16Dec, word32Dec, word64Dec+ , floatDec, doubleDec+ ) import Data.Int (Int8, Int16, Int32, Int64) import Data.List (intersperse) import Data.Monoid (mappend)@@ -35,15 +38,16 @@ import Data.Word (Word, Word8, Word16, Word32, Word64) import {-# SOURCE #-} Database.PostgreSQL.Simple.ToRow import Database.PostgreSQL.Simple.Types-import qualified Blaze.ByteString.Builder.Char.Utf8 as Utf8+import Database.PostgreSQL.Simple.Compat (toByteString)+ import qualified Data.ByteString as SB import qualified Data.ByteString.Lazy as LB import qualified Data.Text as ST import qualified Data.Text.Encoding as ST import qualified Data.Text.Lazy as LT import qualified Data.Text.Lazy.Builder as LT-import Data.UUID (UUID)-import qualified Data.UUID as UUID+import Data.UUID.Types (UUID)+import qualified Data.UUID.Types as UUID import Data.Vector (Vector) import qualified Data.Vector as V import qualified Database.PostgreSQL.LibPQ as PQ@@ -54,6 +58,7 @@ #else import Data.Scientific (scientificBuilder) #endif+import Foreign.C.Types (CUInt(..)) -- | How to render an element when substituting it into a query. data Action =@@ -99,84 +104,84 @@ {-# INLINE toField #-} instance (ToField a) => ToField (In [a]) where- toField (In []) = Plain $ fromByteString "(null)"+ toField (In []) = Plain $ byteString "(null)" toField (In xs) = Many $- Plain (fromChar '(') :- (intersperse (Plain (fromChar ',')) . map toField $ xs) ++- [Plain (fromChar ')')]+ Plain (char8 '(') :+ (intersperse (Plain (char8 ',')) . map toField $ xs) +++ [Plain (char8 ')')] renderNull :: Action-renderNull = Plain (fromByteString "null")+renderNull = Plain (byteString "null") instance ToField Null where toField _ = renderNull {-# INLINE toField #-} instance ToField Default where- toField _ = Plain (fromByteString "default")+ toField _ = Plain (byteString "default") {-# INLINE toField #-} instance ToField Bool where- toField True = Plain (fromByteString "true")- toField False = Plain (fromByteString "false")+ toField True = Plain (byteString "true")+ toField False = Plain (byteString "false") {-# INLINE toField #-} instance ToField Int8 where- toField = Plain . integral+ toField = Plain . int8Dec {-# INLINE toField #-} instance ToField Int16 where- toField = Plain . integral+ toField = Plain . int16Dec {-# INLINE toField #-} instance ToField Int32 where- toField = Plain . integral+ toField = Plain . int32Dec {-# INLINE toField #-} instance ToField Int where- toField = Plain . integral+ toField = Plain . intDec {-# INLINE toField #-} instance ToField Int64 where- toField = Plain . integral+ toField = Plain . int64Dec {-# INLINE toField #-} instance ToField Integer where- toField = Plain . integral+ toField = Plain . integerDec {-# INLINE toField #-} instance ToField Word8 where- toField = Plain . integral+ toField = Plain . word8Dec {-# INLINE toField #-} instance ToField Word16 where- toField = Plain . integral+ toField = Plain . word16Dec {-# INLINE toField #-} instance ToField Word32 where- toField = Plain . integral+ toField = Plain . word32Dec {-# INLINE toField #-} instance ToField Word where- toField = Plain . integral+ toField = Plain . wordDec {-# INLINE toField #-} instance ToField Word64 where- toField = Plain . integral+ toField = Plain . word64Dec {-# INLINE toField #-} instance ToField PQ.Oid where- toField = Plain . integral . \(PQ.Oid x) -> x+ toField = Plain . \(PQ.Oid (CUInt x)) -> word32Dec x {-# INLINE toField #-} instance ToField Float where- toField v | isNaN v || isInfinite v = Plain (inQuotes (float v))- | otherwise = Plain (float v)+ toField v | isNaN v || isInfinite v = Plain (inQuotes (floatDec v))+ | otherwise = Plain (floatDec v) {-# INLINE toField #-} instance ToField Double where- toField v | isNaN v || isInfinite v = Plain (inQuotes (double v))- | otherwise = Plain (double v)+ toField v | isNaN v || isInfinite v = Plain (inQuotes (doubleDec v))+ | otherwise = Plain (doubleDec v) {-# INLINE toField #-} instance ToField Scientific where@@ -198,7 +203,7 @@ instance ToField QualifiedIdentifier where toField (QualifiedIdentifier (Just s) t) = Many [ EscapeIdentifier (ST.encodeUtf8 s)- , Plain (fromChar '.')+ , Plain (char8 '.') , EscapeIdentifier (ST.encodeUtf8 t) ] toField (QualifiedIdentifier Nothing t) =@@ -218,7 +223,7 @@ {-# INLINE toField #-} instance ToField [Char] where- toField = Escape . toByteString . Utf8.fromString+ toField = Escape . toByteString . stringUtf8 {-# INLINE toField #-} instance ToField LT.Text where@@ -268,9 +273,9 @@ instance (ToField a) => ToField (PGArray a) where toField xs = Many $- Plain (fromByteString "ARRAY[") :- (intersperse (Plain (fromChar ',')) . map toField $ fromPGArray xs) ++- [Plain (fromChar ']')]+ Plain (byteString "ARRAY[") :+ (intersperse (Plain (char8 ',')) . map toField $ fromPGArray xs) +++ [Plain (char8 ']')] -- Because the ARRAY[...] input syntax is being used, it is possible -- that the use of type-specific separator characters is unnecessary. @@ -278,7 +283,7 @@ toField = toField . PGArray . V.toList instance ToField UUID where- toField = Plain . inQuotes . fromByteString . UUID.toASCIIBytes+ toField = Plain . inQuotes . byteString . UUID.toASCIIBytes instance ToField JSON.Value where toField = toField . JSON.encode@@ -297,7 +302,7 @@ -- This function /does not/ perform any other escaping. inQuotes :: Builder -> Builder inQuotes b = quote `mappend` b `mappend` quote- where quote = Utf8.fromChar '\''+ where quote = char8 '\'' interleaveFoldr :: (a -> [b] -> [b]) -> b -> [b] -> [a] -> [b] interleaveFoldr f b bs as = foldr (\a bs -> b : f a bs) bs as@@ -318,8 +323,8 @@ funcname = "Database.PostgreSQL.Simple.toField :: Values a -> Action" norows = funcname ++ " either values or types must be non-empty" emptyrow = funcname ++ " each row must contain at least one column"- lit = Plain . fromByteString- litC = Plain . fromChar+ lit = Plain . byteString+ litC = Plain . char8 values x = Many (lit "(VALUES ": x) typedField :: (Action, QualifiedIdentifier) -> [Action] -> [Action]
src/Database/PostgreSQL/Simple/ToField.hs-boot view
@@ -1,7 +1,7 @@ module Database.PostgreSQL.Simple.ToField where import Database.PostgreSQL.Simple.Types-import Blaze.ByteString.Builder(Builder)+import Data.ByteString.Builder(Builder) import Data.ByteString(ByteString) -- | How to render an element when substituting it into a query.
src/Database/PostgreSQL/Simple/TypeInfo/Static.hs view
@@ -41,9 +41,6 @@ , cidr , float4 , float8- , abstime- , reltime- , tinterval , unknown , circle , money@@ -63,9 +60,78 @@ , refcursor , record , void+ , array_record+ , regprocedure+ , regoper+ , regoperator+ , regclass+ , regtype , uuid , json , jsonb+ , int2vector+ , oidvector+ , array_xml+ , array_json+ , array_line+ , array_cidr+ , array_circle+ , array_money+ , array_bool+ , array_bytea+ , array_char+ , array_name+ , array_int2+ , array_int2vector+ , array_int4+ , array_regproc+ , array_text+ , array_tid+ , array_xid+ , array_cid+ , array_oidvector+ , array_bpchar+ , array_varchar+ , array_int8+ , array_point+ , array_lseg+ , array_path+ , array_box+ , array_float4+ , array_float8+ , array_polygon+ , array_oid+ , array_macaddr+ , array_inet+ , array_timestamp+ , array_date+ , array_time+ , array_timestamptz+ , array_interval+ , array_numeric+ , array_timetz+ , array_bit+ , array_varbit+ , array_refcursor+ , array_regprocedure+ , array_regoper+ , array_regoperator+ , array_regclass+ , array_regtype+ , array_uuid+ , array_jsonb+ , int4range+ , _int4range+ , numrange+ , _numrange+ , tsrange+ , _tsrange+ , tstzrange+ , _tstzrange+ , daterange+ , _daterange+ , int8range+ , _int8range ) where import Database.PostgreSQL.LibPQ (Oid(..))@@ -96,9 +162,6 @@ 650 -> Just cidr 700 -> Just float4 701 -> Just float8- 702 -> Just abstime- 703 -> Just reltime- 704 -> Just tinterval 705 -> Just unknown 718 -> Just circle 790 -> Just money@@ -118,9 +181,78 @@ 1790 -> Just refcursor 2249 -> Just record 2278 -> Just void+ 2287 -> Just array_record+ 2202 -> Just regprocedure+ 2203 -> Just regoper+ 2204 -> Just regoperator+ 2205 -> Just regclass+ 2206 -> Just regtype 2950 -> Just uuid 114 -> Just json 3802 -> Just jsonb+ 22 -> Just int2vector+ 30 -> Just oidvector+ 143 -> Just array_xml+ 199 -> Just array_json+ 629 -> Just array_line+ 651 -> Just array_cidr+ 719 -> Just array_circle+ 791 -> Just array_money+ 1000 -> Just array_bool+ 1001 -> Just array_bytea+ 1002 -> Just array_char+ 1003 -> Just array_name+ 1005 -> Just array_int2+ 1006 -> Just array_int2vector+ 1007 -> Just array_int4+ 1008 -> Just array_regproc+ 1009 -> Just array_text+ 1010 -> Just array_tid+ 1011 -> Just array_xid+ 1012 -> Just array_cid+ 1013 -> Just array_oidvector+ 1014 -> Just array_bpchar+ 1015 -> Just array_varchar+ 1016 -> Just array_int8+ 1017 -> Just array_point+ 1018 -> Just array_lseg+ 1019 -> Just array_path+ 1020 -> Just array_box+ 1021 -> Just array_float4+ 1022 -> Just array_float8+ 1027 -> Just array_polygon+ 1028 -> Just array_oid+ 1040 -> Just array_macaddr+ 1041 -> Just array_inet+ 1115 -> Just array_timestamp+ 1182 -> Just array_date+ 1183 -> Just array_time+ 1185 -> Just array_timestamptz+ 1187 -> Just array_interval+ 1231 -> Just array_numeric+ 1270 -> Just array_timetz+ 1561 -> Just array_bit+ 1563 -> Just array_varbit+ 2201 -> Just array_refcursor+ 2207 -> Just array_regprocedure+ 2208 -> Just array_regoper+ 2209 -> Just array_regoperator+ 2210 -> Just array_regclass+ 2211 -> Just array_regtype+ 2951 -> Just array_uuid+ 3807 -> Just array_jsonb+ 3904 -> Just int4range+ 3905 -> Just _int4range+ 3906 -> Just numrange+ 3907 -> Just _numrange+ 3908 -> Just tsrange+ 3909 -> Just _tsrange+ 3910 -> Just tstzrange+ 3911 -> Just _tstzrange+ 3912 -> Just daterange+ 3913 -> Just _daterange+ 3926 -> Just int8range+ 3927 -> Just _int8range _ -> Nothing bool :: TypeInfo@@ -307,30 +439,6 @@ typname = "float8" } -abstime :: TypeInfo-abstime = Basic {- typoid = Oid 702,- typcategory = 'D',- typdelim = ',',- typname = "abstime"- }--reltime :: TypeInfo-reltime = Basic {- typoid = Oid 703,- typcategory = 'T',- typdelim = ',',- typname = "reltime"- }--tinterval :: TypeInfo-tinterval = Basic {- typoid = Oid 704,- typcategory = 'T',- typdelim = ',',- typname = "tinterval"- }- unknown :: TypeInfo unknown = Basic { typoid = Oid 705,@@ -483,6 +591,55 @@ typname = "void" } +array_record :: TypeInfo+array_record = Array {+ typoid = Oid 2287,+ typcategory = 'P',+ typdelim = ',',+ typname = "_record",+ typelem = record+ }++regprocedure :: TypeInfo+regprocedure = Basic {+ typoid = Oid 2202,+ typcategory = 'N',+ typdelim = ',',+ typname = "regprocedure"+ }++regoper :: TypeInfo+regoper = Basic {+ typoid = Oid 2203,+ typcategory = 'N',+ typdelim = ',',+ typname = "regoper"+ }++regoperator :: TypeInfo+regoperator = Basic {+ typoid = Oid 2204,+ typcategory = 'N',+ typdelim = ',',+ typname = "regoperator"+ }++regclass :: TypeInfo+regclass = Basic {+ typoid = Oid 2205,+ typcategory = 'N',+ typdelim = ',',+ typname = "regclass"+ }++regtype :: TypeInfo+regtype = Basic {+ typoid = Oid 2206,+ typcategory = 'N',+ typdelim = ',',+ typname = "regtype"+ }+ uuid :: TypeInfo uuid = Basic { typoid = Oid 2950,@@ -505,4 +662,571 @@ typcategory = 'U', typdelim = ',', typname = "jsonb"+ }++int2vector :: TypeInfo+int2vector = Array {+ typoid = Oid 22,+ typcategory = 'A',+ typdelim = ',',+ typname = "int2vector",+ typelem = int2+ }++oidvector :: TypeInfo+oidvector = Array {+ typoid = Oid 30,+ typcategory = 'A',+ typdelim = ',',+ typname = "oidvector",+ typelem = oid+ }++array_xml :: TypeInfo+array_xml = Array {+ typoid = Oid 143,+ typcategory = 'A',+ typdelim = ',',+ typname = "_xml",+ typelem = xml+ }++array_json :: TypeInfo+array_json = Array {+ typoid = Oid 199,+ typcategory = 'A',+ typdelim = ',',+ typname = "_json",+ typelem = json+ }++array_line :: TypeInfo+array_line = Array {+ typoid = Oid 629,+ typcategory = 'A',+ typdelim = ',',+ typname = "_line",+ typelem = line+ }++array_cidr :: TypeInfo+array_cidr = Array {+ typoid = Oid 651,+ typcategory = 'A',+ typdelim = ',',+ typname = "_cidr",+ typelem = cidr+ }++array_circle :: TypeInfo+array_circle = Array {+ typoid = Oid 719,+ typcategory = 'A',+ typdelim = ',',+ typname = "_circle",+ typelem = circle+ }++array_money :: TypeInfo+array_money = Array {+ typoid = Oid 791,+ typcategory = 'A',+ typdelim = ',',+ typname = "_money",+ typelem = money+ }++array_bool :: TypeInfo+array_bool = Array {+ typoid = Oid 1000,+ typcategory = 'A',+ typdelim = ',',+ typname = "_bool",+ typelem = bool+ }++array_bytea :: TypeInfo+array_bytea = Array {+ typoid = Oid 1001,+ typcategory = 'A',+ typdelim = ',',+ typname = "_bytea",+ typelem = bytea+ }++array_char :: TypeInfo+array_char = Array {+ typoid = Oid 1002,+ typcategory = 'A',+ typdelim = ',',+ typname = "_char",+ typelem = char+ }++array_name :: TypeInfo+array_name = Array {+ typoid = Oid 1003,+ typcategory = 'A',+ typdelim = ',',+ typname = "_name",+ typelem = name+ }++array_int2 :: TypeInfo+array_int2 = Array {+ typoid = Oid 1005,+ typcategory = 'A',+ typdelim = ',',+ typname = "_int2",+ typelem = int2+ }++array_int2vector :: TypeInfo+array_int2vector = Array {+ typoid = Oid 1006,+ typcategory = 'A',+ typdelim = ',',+ typname = "_int2vector",+ typelem = int2vector+ }++array_int4 :: TypeInfo+array_int4 = Array {+ typoid = Oid 1007,+ typcategory = 'A',+ typdelim = ',',+ typname = "_int4",+ typelem = int4+ }++array_regproc :: TypeInfo+array_regproc = Array {+ typoid = Oid 1008,+ typcategory = 'A',+ typdelim = ',',+ typname = "_regproc",+ typelem = regproc+ }++array_text :: TypeInfo+array_text = Array {+ typoid = Oid 1009,+ typcategory = 'A',+ typdelim = ',',+ typname = "_text",+ typelem = text+ }++array_tid :: TypeInfo+array_tid = Array {+ typoid = Oid 1010,+ typcategory = 'A',+ typdelim = ',',+ typname = "_tid",+ typelem = tid+ }++array_xid :: TypeInfo+array_xid = Array {+ typoid = Oid 1011,+ typcategory = 'A',+ typdelim = ',',+ typname = "_xid",+ typelem = xid+ }++array_cid :: TypeInfo+array_cid = Array {+ typoid = Oid 1012,+ typcategory = 'A',+ typdelim = ',',+ typname = "_cid",+ typelem = cid+ }++array_oidvector :: TypeInfo+array_oidvector = Array {+ typoid = Oid 1013,+ typcategory = 'A',+ typdelim = ',',+ typname = "_oidvector",+ typelem = oidvector+ }++array_bpchar :: TypeInfo+array_bpchar = Array {+ typoid = Oid 1014,+ typcategory = 'A',+ typdelim = ',',+ typname = "_bpchar",+ typelem = bpchar+ }++array_varchar :: TypeInfo+array_varchar = Array {+ typoid = Oid 1015,+ typcategory = 'A',+ typdelim = ',',+ typname = "_varchar",+ typelem = varchar+ }++array_int8 :: TypeInfo+array_int8 = Array {+ typoid = Oid 1016,+ typcategory = 'A',+ typdelim = ',',+ typname = "_int8",+ typelem = int8+ }++array_point :: TypeInfo+array_point = Array {+ typoid = Oid 1017,+ typcategory = 'A',+ typdelim = ',',+ typname = "_point",+ typelem = point+ }++array_lseg :: TypeInfo+array_lseg = Array {+ typoid = Oid 1018,+ typcategory = 'A',+ typdelim = ',',+ typname = "_lseg",+ typelem = lseg+ }++array_path :: TypeInfo+array_path = Array {+ typoid = Oid 1019,+ typcategory = 'A',+ typdelim = ',',+ typname = "_path",+ typelem = path+ }++array_box :: TypeInfo+array_box = Array {+ typoid = Oid 1020,+ typcategory = 'A',+ typdelim = ';',+ typname = "_box",+ typelem = box+ }++array_float4 :: TypeInfo+array_float4 = Array {+ typoid = Oid 1021,+ typcategory = 'A',+ typdelim = ',',+ typname = "_float4",+ typelem = float4+ }++array_float8 :: TypeInfo+array_float8 = Array {+ typoid = Oid 1022,+ typcategory = 'A',+ typdelim = ',',+ typname = "_float8",+ typelem = float8+ }++array_polygon :: TypeInfo+array_polygon = Array {+ typoid = Oid 1027,+ typcategory = 'A',+ typdelim = ',',+ typname = "_polygon",+ typelem = polygon+ }++array_oid :: TypeInfo+array_oid = Array {+ typoid = Oid 1028,+ typcategory = 'A',+ typdelim = ',',+ typname = "_oid",+ typelem = oid+ }++array_macaddr :: TypeInfo+array_macaddr = Array {+ typoid = Oid 1040,+ typcategory = 'A',+ typdelim = ',',+ typname = "_macaddr",+ typelem = macaddr+ }++array_inet :: TypeInfo+array_inet = Array {+ typoid = Oid 1041,+ typcategory = 'A',+ typdelim = ',',+ typname = "_inet",+ typelem = inet+ }++array_timestamp :: TypeInfo+array_timestamp = Array {+ typoid = Oid 1115,+ typcategory = 'A',+ typdelim = ',',+ typname = "_timestamp",+ typelem = timestamp+ }++array_date :: TypeInfo+array_date = Array {+ typoid = Oid 1182,+ typcategory = 'A',+ typdelim = ',',+ typname = "_date",+ typelem = date+ }++array_time :: TypeInfo+array_time = Array {+ typoid = Oid 1183,+ typcategory = 'A',+ typdelim = ',',+ typname = "_time",+ typelem = time+ }++array_timestamptz :: TypeInfo+array_timestamptz = Array {+ typoid = Oid 1185,+ typcategory = 'A',+ typdelim = ',',+ typname = "_timestamptz",+ typelem = timestamptz+ }++array_interval :: TypeInfo+array_interval = Array {+ typoid = Oid 1187,+ typcategory = 'A',+ typdelim = ',',+ typname = "_interval",+ typelem = interval+ }++array_numeric :: TypeInfo+array_numeric = Array {+ typoid = Oid 1231,+ typcategory = 'A',+ typdelim = ',',+ typname = "_numeric",+ typelem = numeric+ }++array_timetz :: TypeInfo+array_timetz = Array {+ typoid = Oid 1270,+ typcategory = 'A',+ typdelim = ',',+ typname = "_timetz",+ typelem = timetz+ }++array_bit :: TypeInfo+array_bit = Array {+ typoid = Oid 1561,+ typcategory = 'A',+ typdelim = ',',+ typname = "_bit",+ typelem = bit+ }++array_varbit :: TypeInfo+array_varbit = Array {+ typoid = Oid 1563,+ typcategory = 'A',+ typdelim = ',',+ typname = "_varbit",+ typelem = varbit+ }++array_refcursor :: TypeInfo+array_refcursor = Array {+ typoid = Oid 2201,+ typcategory = 'A',+ typdelim = ',',+ typname = "_refcursor",+ typelem = refcursor+ }++array_regprocedure :: TypeInfo+array_regprocedure = Array {+ typoid = Oid 2207,+ typcategory = 'A',+ typdelim = ',',+ typname = "_regprocedure",+ typelem = regprocedure+ }++array_regoper :: TypeInfo+array_regoper = Array {+ typoid = Oid 2208,+ typcategory = 'A',+ typdelim = ',',+ typname = "_regoper",+ typelem = regoper+ }++array_regoperator :: TypeInfo+array_regoperator = Array {+ typoid = Oid 2209,+ typcategory = 'A',+ typdelim = ',',+ typname = "_regoperator",+ typelem = regoperator+ }++array_regclass :: TypeInfo+array_regclass = Array {+ typoid = Oid 2210,+ typcategory = 'A',+ typdelim = ',',+ typname = "_regclass",+ typelem = regclass+ }++array_regtype :: TypeInfo+array_regtype = Array {+ typoid = Oid 2211,+ typcategory = 'A',+ typdelim = ',',+ typname = "_regtype",+ typelem = regtype+ }++array_uuid :: TypeInfo+array_uuid = Array {+ typoid = Oid 2951,+ typcategory = 'A',+ typdelim = ',',+ typname = "_uuid",+ typelem = uuid+ }++array_jsonb :: TypeInfo+array_jsonb = Array {+ typoid = Oid 3807,+ typcategory = 'A',+ typdelim = ',',+ typname = "_jsonb",+ typelem = jsonb+ }++int4range :: TypeInfo+int4range = Range {+ typoid = Oid 3904,+ typcategory = 'R',+ typdelim = ',',+ typname = "int4range",+ rngsubtype = int4+ }++_int4range :: TypeInfo+_int4range = Array {+ typoid = Oid 3905,+ typcategory = 'A',+ typdelim = ',',+ typname = "_int4range",+ typelem = int4range+ }++numrange :: TypeInfo+numrange = Range {+ typoid = Oid 3906,+ typcategory = 'R',+ typdelim = ',',+ typname = "numrange",+ rngsubtype = numeric+ }++_numrange :: TypeInfo+_numrange = Array {+ typoid = Oid 3907,+ typcategory = 'A',+ typdelim = ',',+ typname = "_numrange",+ typelem = numrange+ }++tsrange :: TypeInfo+tsrange = Range {+ typoid = Oid 3908,+ typcategory = 'R',+ typdelim = ',',+ typname = "tsrange",+ rngsubtype = timestamp+ }++_tsrange :: TypeInfo+_tsrange = Array {+ typoid = Oid 3909,+ typcategory = 'A',+ typdelim = ',',+ typname = "_tsrange",+ typelem = tsrange+ }++tstzrange :: TypeInfo+tstzrange = Range {+ typoid = Oid 3910,+ typcategory = 'R',+ typdelim = ',',+ typname = "tstzrange",+ rngsubtype = timestamptz+ }++_tstzrange :: TypeInfo+_tstzrange = Array {+ typoid = Oid 3911,+ typcategory = 'A',+ typdelim = ',',+ typname = "_tstzrange",+ typelem = tstzrange+ }++daterange :: TypeInfo+daterange = Range {+ typoid = Oid 3912,+ typcategory = 'R',+ typdelim = ',',+ typname = "daterange",+ rngsubtype = date+ }++_daterange :: TypeInfo+_daterange = Array {+ typoid = Oid 3913,+ typcategory = 'A',+ typdelim = ',',+ typname = "_daterange",+ typelem = daterange+ }++int8range :: TypeInfo+int8range = Range {+ typoid = Oid 3926,+ typcategory = 'R',+ typdelim = ',',+ typname = "int8range",+ rngsubtype = int8+ }++_int8range :: TypeInfo+_int8range = Array {+ typoid = Oid 3927,+ typcategory = 'A',+ typdelim = ',',+ typname = "_int8range",+ typelem = int8range }
src/Database/PostgreSQL/Simple/Types.hs view
@@ -30,18 +30,18 @@ , Values(..) ) where -import Blaze.ByteString.Builder (toByteString) import Control.Arrow (first) import Data.ByteString (ByteString) import Data.Hashable (Hashable(hashWithSalt)) import Data.Monoid (Monoid(..)) import Data.String (IsString(..)) import Data.Typeable (Typeable)-import qualified Blaze.ByteString.Builder.Char.Utf8 as Utf8+import Data.ByteString.Builder ( stringUtf8 ) import qualified Data.ByteString as B import Data.Text (Text) import qualified Data.Text as T import Database.PostgreSQL.LibPQ (Oid(..))+import Database.PostgreSQL.Simple.Compat (toByteString) -- | A placeholder for the SQL @NULL@ value. data Null = Null@@ -85,7 +85,7 @@ readsPrec i = fmap (first Query) . readsPrec i instance IsString Query where- fromString = Query . toByteString . Utf8.fromString+ fromString = Query . toByteString . stringUtf8 instance Monoid Query where mempty = Query B.empty
test/Main.hs view
@@ -184,6 +184,8 @@ roundTrip (Map.fromList [("foo","bar"),("bar","baz"),("baz","hello")] :: Map Text Text) roundTrip (Map.fromList [("fo\"o","bar"),("b\\ar","baz"),("baz","\"value\\with\"escapes")] :: Map Text Text) roundTrip (V.fromList [1,2,3,4,5::Int])+ roundTrip ("foo" :: Text)+ roundTrip (42 :: Int) where roundTrip :: ToJSON a => a -> Assertion roundTrip a = do