packages feed

postgresql-typed 0.3.0 → 0.3.1

raw patch · 13 files changed

+806/−551 lines, 13 files

Files

Database/PostgreSQL/Typed.hs view
@@ -71,7 +71,7 @@ -- While compile-time query analysis eliminates many errors, it doesn't -- eliminate all of them. If you modify the database without recompilation or -- have an error in a trigger or function, for example, you can still trigger a--- 'PGException' or other failure (if types change).  Also, nullable result fields resulting from outer joins are not+-- 'PGError' or other failure (if types change).  Also, nullable result fields resulting from outer joins are not -- detected and need to be handled explicitly. -- -- Based originally on Chris Forno's TemplatePG library.@@ -102,12 +102,11 @@ --  -- [@TPG_PORT@ or @TPG_SOCK@] the port number or local socket path to connect on (default: @5432@) -- --- If you'd like to specify what connection to use directly, use 'useTHConnection' at the top level:+-- If you'd like to specify what connection to use directly, use 'useTPGDatabase' at the top level: ----- > myConnect = pgConnect ...--- > useTHConnection myConnect+-- > useTPGDatabase PGDatabase{ ... } ----- Note that due to TH limitations, @myConnect@ must be in-line or in a different module, and must be processed by the compiler before (above) any other TH calls.+-- Note that due to TH limitations, the database must be in-line or in a different module.  This call must be processed by the compiler before (above) any other TH calls. -- -- You can set @TPG_DEBUG@ at compile or runtime to get a protocol-level trace. @@ -119,7 +118,7 @@ -- -- > let q = [pgSQL|SELECT id, name, address FROM people WHERE name LIKE ${query++"%"} OR email LIKE $1|] :: PGSimpleQuery [(Int32, String, Maybe String)] ----- Expression placeholders are substituted by PostgreSQL ones in left-to-right order starting with 1, so must be in places that PostgreSQL allows them (e.g., not identifiers, table names, column names, operators, etc.)+-- Expression placeholders are substituted with PostgreSQL ones in left-to-right order starting with 1, so must be in places that PostgreSQL allows them (e.g., not identifiers, table names, column names, operators, etc.) -- However, this does mean that you can repeat expressions using the corresponding PostgreSQL placeholder as above. -- If there are extra PostgreSQL parameters the may be passed as arguments: --@@ -137,7 +136,7 @@ --  -- 'PGPreparedQuery' is a bit more complex: the first time any given prepared query is run on a given connection, the query is prepared.  Every subsequent time, the previously-prepared query is re-used and the new placeholder values are bound to it. -- Queries are identified by the text of the SQL statement with PostgreSQL placeholders in-place, so the exact parameter values do not matter (but the exact SQL statement, whitespace, etc. does).--- (Prepared queries are released automatically at 'pgDisconnect', but may be closed early using 'pgCloseQuery'.)+-- (Prepared queries are released automatically at 'pgDisconnect', but may be closed early using 'Database.PostgreSQL.Typed.Protocol.pgCloseQuery'.)  -- $templatepg -- There is also an older, simpler interface based on TemplatePG that combines both the compile and runtime steps.@@ -149,7 +148,7 @@ -- given one at compile-time, so you need to pass it after the splice: -- -- > h <- pgConnect ...--- > tuples <- $(queryTuples \"SELECT * FROM pg_database\") h+-- > tuples <- $(queryTuples "SELECT * FROM pg_database") h -- -- To pass parameters to a query, include them in the string with {}. Most -- Haskell expressions should work. For example:@@ -157,22 +156,31 @@ -- > let owner = 33 :: Int32 -- > tuples <- $(queryTuples "SELECT * FROM pg_database WHERE datdba = {owner} LIMIT {2 * 3 :: Int64}") h -- --- TemplatePG provides 'withTransaction', 'rollback', and 'insertIgnore', but they've+-- TemplatePG provides 'Database.PostgreSQL.Typed.TemplatePG.withTransaction', 'Database.PostgreSQL.Typed.TemplatePG.rollback', and 'Database.PostgreSQL.Typed.TemplatePG.insertIgnore', but they've -- not been thoroughly tested, so use them at your own risk.  -- $types -- Most builtin types are already supported. -- For the most part, exactly equivalent types are all supported (e.g., 'Int32' for int4) as well as other safe equivalents, but you cannot, for example, pass an 'Integer' as a @smallint@. -- To achieve this flexibility, the exact types of all parameters and results must be fully known (e.g., numeric literals will not work).--- Currenly only 1-dimentional arrays are supported. ----- However you can add support for your own types or add flexibility to existing types by creating new instances of 'PGParameter' (for encoding) and 'PGColumn' (for decoding).--- If you also want to support arrays of a new type, you should also provide a 'PGArrayType' instance (or 'PGRangeType' for new ranges):+-- However you can add support for your own types or add flexibility to existing types by creating new instances of 'Database.PostgreSQL.Typed.Types.PGParameter' (for encoding) and 'Database.PostgreSQL.Typed.Types.PGColumn' (for decoding). -- +-- > instance PGType "mytype" -- > instance PGParameter "mytype" MyType where -- >   pgEncode _ (v :: MyType) = ... :: ByteString -- > instance PGColumn "mytype" MyType where -- >   pgDecode _ (s :: ByteString) = ... :: MyType+-- +-- You can make as many 'PGParameter' and 'PGColumn' instances as you want if you want to support different representations of your type.+-- If you want to use any of the functions in "Database.PostgreSQL.Typed.Dynamic", however, such as 'Database.PostgreSQL.Typed.Dynamic.pgSafeLiteral', you must define a default representation:+--+-- > instance PGRep "mytype" MyType+--+-- If you want to support arrays of your new type, you should also provide a 'Database.PostgreSQL.Typed.Array.PGArrayType' instance (or 'Database.PostgreSQL.Typed.Range.PGRangeType' for new ranges).+-- Currently only 1-dimensional arrays are supported.+--+-- > instance PGType "mytype[]" -- > instance PGArrayType "mytype[]" "mytype" -- -- Required language extensions: FlexibleInstances, MultiParamTypeClasses, DataKinds@@ -193,18 +201,17 @@ -- You cannot construct queries at run-time, since they -- wouldn't be available to be analyzed at compile time (but you can construct them at compile time by writing your own TH functions). ----- Because of how PostgreSQL handles placeholders, they cannot be used in place of lists (such as @IN (?)@), you must replace such cases with equivalent arrays (@= ANY (?)@).+-- Because of how PostgreSQL handles placeholders, they cannot be used in place of lists (such as @IN (?)@). You must replace such cases with equivalent arrays (@= ANY (?)@). -- -- For the most part, any code must be compiled and run against databases that are at least structurally identical.--- However, some features have even stronger requirements:------   * The @$(type, ...)@ feature stores OIDs for user types, so the resulting code can only be run the exact same database or one restored from a dump with OIDs (@pg_dump -o@).  If this is a concern, only use built-in types in this construct.+-- Furthermore, prepared queries also store OIDs for user types, so the generated 'PGPreparedQuery' can only be run on the exact same database or one restored from a dump with OIDs (@pg_dump -o@).  If this is a concern, only use built-in types in prepared queries.+-- (This requirement could be weakened with some work, if there were need.)  -- $tips -- If you find yourself pattern matching on result tuples just to pass them on -- to functions, you can use @uncurryN@ from the tuple package. The following -- examples are equivalent. ----- > (a, b, c) <- $(queryTuple \"SELECT a, b, c FROM table LIMIT 1\")+-- > (a, b, c) <- $(queryTuple "SELECT a, b, c FROM table LIMIT 1") -- > someFunction a b c--- > uncurryN someFunction \`liftM\` $(queryTuple \"SELECT a, b, c FROM table LIMIT 1\")+-- > uncurryN someFunction `liftM` $(queryTuple "SELECT a, b, c FROM table LIMIT 1")
+ Database/PostgreSQL/Typed/Array.hs view
@@ -0,0 +1,185 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FunctionalDependencies, UndecidableInstances, DataKinds #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- |+-- Module: Database.PostgreSQL.Typed.Array+-- Copyright: 2015 Dylan Simon+-- +-- Representaion of PostgreSQL's array type.+-- Currently this only supports one-dimensional arrays.+-- PostgreSQL arrays in theory can dynamically be any (rectangular) shape.++module Database.PostgreSQL.Typed.Array where++import Control.Applicative ((<$>), (<$))+import qualified Data.ByteString.Builder as BSB+import qualified Data.ByteString.Char8 as BSC+import Data.List (intersperse)+import Data.Monoid ((<>), mconcat)+import qualified Text.Parsec as P++import Database.PostgreSQL.Typed.Types++-- |The cannonical representation of a PostgreSQL array of any type, which may always contain NULLs.+-- Currenly only one-dimetional arrays are supported, although in PostgreSQL, any array may be of any dimentionality.+type PGArray a = [Maybe a]++-- |Class indicating that the first PostgreSQL type is an array of the second.+-- This implies 'PGParameter' and 'PGColumn' instances that will work for any type using comma as a delimiter (i.e., anything but @box@).+-- This will only work with 1-dimensional arrays.+class (PGType ta, PGType t) => PGArrayType ta t | ta -> t, t -> ta where+  pgArrayElementType :: PGTypeName ta -> PGTypeName t+  pgArrayElementType PGTypeProxy = PGTypeProxy+  -- |The character used as a delimeter.  The default @,@ is correct for all standard types (except @box@).+  pgArrayDelim :: PGTypeName ta -> Char+  pgArrayDelim _ = ','++instance (PGArrayType ta t, PGParameter t a) => PGParameter ta (PGArray a) where+  pgEncode ta l = buildPGValue $ BSB.char7 '{' <> mconcat (intersperse (BSB.char7 $ pgArrayDelim ta) $ map el l) <> BSB.char7 '}' where+    el Nothing = BSB.string7 "null"+    el (Just e) = pgDQuote (pgArrayDelim ta : "{}") $ pgEncode (pgArrayElementType ta) e+instance (PGArrayType ta t, PGColumn t a) => PGColumn ta (PGArray a) where+  pgDecode ta = either (error . ("pgDecode array: " ++) . show) id . P.parse pa "array" where+    pa = do+      l <- P.between (P.char '{') (P.char '}') $+        P.sepBy nel (P.char (pgArrayDelim ta))+      _ <- P.eof+      return l+    nel = P.between P.spaces P.spaces $ Nothing <$ nul P.<|> Just <$> el+    nul = P.oneOf "Nn" >> P.oneOf "Uu" >> P.oneOf "Ll" >> P.oneOf "Ll"+    el = pgDecode (pgArrayElementType ta) . BSC.pack <$> parsePGDQuote (pgArrayDelim ta : "{}")++-- Just a dump of pg_type:+instance PGType "boolean" => PGType "boolean[]"+instance PGType "boolean" => PGArrayType "boolean[]" "boolean"+instance PGType "bytea" => PGType "bytea[]"+instance PGType "bytea" => PGArrayType "bytea[]" "bytea"+instance PGType "\"char\"" => PGType "\"char\"[]"+instance PGType "\"char\"" => PGArrayType "\"char\"[]" "\"char\""+instance PGType "name" => PGType "name[]"+instance PGType "name" => PGArrayType "name[]" "name"+instance PGType "bigint" => PGType "bigint[]"+instance PGType "bigint" => PGArrayType "bigint[]" "bigint"+instance PGType "smallint" => PGType "smallint[]"+instance PGType "smallint" => PGArrayType "smallint[]" "smallint"+instance PGType "int2vector" => PGType "int2vector[]"+instance PGType "int2vector" => PGArrayType "int2vector[]" "int2vector"+instance PGType "integer" => PGType "integer[]"+instance PGType "integer" => PGArrayType "integer[]" "integer"+instance PGType "regproc" => PGType "regproc[]"+instance PGType "regproc" => PGArrayType "regproc[]" "regproc"+instance PGType "text" => PGType "text[]"+instance PGType "text" => PGArrayType "text[]" "text"+instance PGType "oid" => PGType "oid[]"+instance PGType "oid" => PGArrayType "oid[]" "oid"+instance PGType "tid" => PGType "tid[]"+instance PGType "tid" => PGArrayType "tid[]" "tid"+instance PGType "xid" => PGType "xid[]"+instance PGType "xid" => PGArrayType "xid[]" "xid"+instance PGType "cid" => PGType "cid[]"+instance PGType "cid" => PGArrayType "cid[]" "cid"+instance PGType "oidvector" => PGType "oidvector[]"+instance PGType "oidvector" => PGArrayType "oidvector[]" "oidvector"+instance PGType "json" => PGType "json[]"+instance PGType "json" => PGArrayType "json[]" "json"+instance PGType "xml" => PGType "xml[]"+instance PGType "xml" => PGArrayType "xml[]" "xml"+instance PGType "point" => PGType "point[]"+instance PGType "point" => PGArrayType "point[]" "point"+instance PGType "lseg" => PGType "lseg[]"+instance PGType "lseg" => PGArrayType "lseg[]" "lseg"+instance PGType "path" => PGType "path[]"+instance PGType "path" => PGArrayType "path[]" "path"+instance PGType "box" => PGType "box[]"+instance PGType "box" => PGArrayType "box[]" "box" where+  pgArrayDelim _ = ';'+instance PGType "polygon" => PGType "polygon[]"+instance PGType "polygon" => PGArrayType "polygon[]" "polygon"+instance PGType "line" => PGType "line[]"+instance PGType "line" => PGArrayType "line[]" "line"+instance PGType "cidr" => PGType "cidr[]"+instance PGType "cidr" => PGArrayType "cidr[]" "cidr"+instance PGType "real" => PGType "real[]"+instance PGType "real" => PGArrayType "real[]" "real"+instance PGType "double precision" => PGType "double precision[]"+instance PGType "double precision" => PGArrayType "double precision[]" "double precision"+instance PGType "abstime" => PGType "abstime[]"+instance PGType "abstime" => PGArrayType "abstime[]" "abstime"+instance PGType "reltime" => PGType "reltime[]"+instance PGType "reltime" => PGArrayType "reltime[]" "reltime"+instance PGType "tinterval" => PGType "tinterval[]"+instance PGType "tinterval" => PGArrayType "tinterval[]" "tinterval"+instance PGType "circle" => PGType "circle[]"+instance PGType "circle" => PGArrayType "circle[]" "circle"+instance PGType "money" => PGType "money[]"+instance PGType "money" => PGArrayType "money[]" "money"+instance PGType "macaddr" => PGType "macaddr[]"+instance PGType "macaddr" => PGArrayType "macaddr[]" "macaddr"+instance PGType "inet" => PGType "inet[]"+instance PGType "inet" => PGArrayType "inet[]" "inet"+instance PGType "aclitem" => PGType "aclitem[]"+instance PGType "aclitem" => PGArrayType "aclitem[]" "aclitem"+instance PGType "bpchar" => PGType "bpchar[]"+instance PGType "bpchar" => PGArrayType "bpchar[]" "bpchar"+instance PGType "character varying" => PGType "character varying[]"+instance PGType "character varying" => PGArrayType "character varying[]" "character varying"+instance PGType "date" => PGType "date[]"+instance PGType "date" => PGArrayType "date[]" "date"+instance PGType "time without time zone" => PGType "time without time zone[]"+instance PGType "time without time zone" => PGArrayType "time without time zone[]" "time without time zone"+instance PGType "timestamp without time zone" => PGType "timestamp without time zone[]"+instance PGType "timestamp without time zone" => PGArrayType "timestamp without time zone[]" "timestamp without time zone"+instance PGType "timestamp with time zone" => PGType "timestamp with time zone[]"+instance PGType "timestamp with time zone" => PGArrayType "timestamp with time zone[]" "timestamp with time zone"+instance PGType "interval" => PGType "interval[]"+instance PGType "interval" => PGArrayType "interval[]" "interval"+instance PGType "time with time zone" => PGType "time with time zone[]"+instance PGType "time with time zone" => PGArrayType "time with time zone[]" "time with time zone"+instance PGType "bit" => PGType "bit[]"+instance PGType "bit" => PGArrayType "bit[]" "bit"+instance PGType "varbit" => PGType "varbit[]"+instance PGType "varbit" => PGArrayType "varbit[]" "varbit"+instance PGType "numeric" => PGType "numeric[]"+instance PGType "numeric" => PGArrayType "numeric[]" "numeric"+instance PGType "refcursor" => PGType "refcursor[]"+instance PGType "refcursor" => PGArrayType "refcursor[]" "refcursor"+instance PGType "regprocedure" => PGType "regprocedure[]"+instance PGType "regprocedure" => PGArrayType "regprocedure[]" "regprocedure"+instance PGType "regoper" => PGType "regoper[]"+instance PGType "regoper" => PGArrayType "regoper[]" "regoper"+instance PGType "regoperator" => PGType "regoperator[]"+instance PGType "regoperator" => PGArrayType "regoperator[]" "regoperator"+instance PGType "regclass" => PGType "regclass[]"+instance PGType "regclass" => PGArrayType "regclass[]" "regclass"+instance PGType "regtype" => PGType "regtype[]"+instance PGType "regtype" => PGArrayType "regtype[]" "regtype"+instance PGType "record" => PGType "record[]"+instance PGType "record" => PGArrayType "record[]" "record"+instance PGType "cstring" => PGType "cstring[]"+instance PGType "cstring" => PGArrayType "cstring[]" "cstring"+instance PGType "uuid" => PGType "uuid[]"+instance PGType "uuid" => PGArrayType "uuid[]" "uuid"+instance PGType "txid_snapshot" => PGType "txid_snapshot[]"+instance PGType "txid_snapshot" => PGArrayType "txid_snapshot[]" "txid_snapshot"+instance PGType "tsvector" => PGType "tsvector[]"+instance PGType "tsvector" => PGArrayType "tsvector[]" "tsvector"+instance PGType "tsquery" => PGType "tsquery[]"+instance PGType "tsquery" => PGArrayType "tsquery[]" "tsquery"+instance PGType "gtsvector" => PGType "gtsvector[]"+instance PGType "gtsvector" => PGArrayType "gtsvector[]" "gtsvector"+instance PGType "regconfig" => PGType "regconfig[]"+instance PGType "regconfig" => PGArrayType "regconfig[]" "regconfig"+instance PGType "regdictionary" => PGType "regdictionary[]"+instance PGType "regdictionary" => PGArrayType "regdictionary[]" "regdictionary"+instance PGType "int4range" => PGType "int4range[]"+instance PGType "int4range" => PGArrayType "int4range[]" "int4range"+instance PGType "numrange" => PGType "numrange[]"+instance PGType "numrange" => PGArrayType "numrange[]" "numrange"+instance PGType "tsrange" => PGType "tsrange[]"+instance PGType "tsrange" => PGArrayType "tsrange[]" "tsrange"+instance PGType "tstzrange" => PGType "tstzrange[]"+instance PGType "tstzrange" => PGArrayType "tstzrange[]" "tstzrange"+instance PGType "daterange" => PGType "daterange[]"+instance PGType "daterange" => PGArrayType "daterange[]" "daterange"+instance PGType "int8range" => PGType "int8range[]"+instance PGType "int8range" => PGArrayType "int8range[]" "int8range"+
+ Database/PostgreSQL/Typed/Dynamic.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE CPP, FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables, FunctionalDependencies, UndecidableInstances, DataKinds, DefaultSignatures, PatternGuards, TemplateHaskell #-}+-- |+-- Module: Database.PostgreSQL.Typed.Dynamic+-- Copyright: 2015 Dylan Simon+-- +-- Automatic (dynamic) marshalling of PostgreSQL values based on Haskell types (not SQL statements).+-- This is intended for direct construction of queries and query data, bypassing the normal SQL type inference.++module Database.PostgreSQL.Typed.Dynamic +  ( PGRep(..)+  , pgSafeLiteral+  , pgSubstituteLiterals+  ) where++import Control.Applicative ((<$>))+import Data.Int+#ifdef USE_SCIENTIFIC+import Data.Scientific (Scientific)+#endif+#ifdef USE_TEXT+import qualified Data.Text as T+#endif+import qualified Data.Time as Time+#ifdef USE_UUID+import qualified Data.UUID as UUID+#endif+import Language.Haskell.Meta.Parse (parseExp)+import qualified Language.Haskell.TH as TH++import Database.PostgreSQL.Typed.Internal+import Database.PostgreSQL.Typed.Types++-- |Represents canonical/default PostgreSQL representation for various Haskell types, allowing convenient type-driven marshalling.+class PGType t => PGRep t a | a -> t where+  pgTypeOf :: a -> PGTypeName t+  pgTypeOf _ = PGTypeProxy+  pgEncodeRep :: a -> PGValue+  default pgEncodeRep :: PGParameter t a => a -> PGValue+  pgEncodeRep x = pgEncodeValue unknownPGTypeEnv (pgTypeOf x) x+  pgLiteralRep :: a -> String+  default pgLiteralRep :: PGParameter t a => a -> String+  pgLiteralRep x = pgLiteral (pgTypeOf x) x+  pgDecodeRep :: PGValue -> a+#ifdef USE_BINARY_XXX+  default pgDecodeRep :: PGBinaryColumn t a => PGValue -> a+  pgDecodeRep (PGBinaryValue v) = pgDecodeBinary unknownPGTypeEnv (PGTypeProxy :: PGTypeName t) v+#else+  default pgDecodeRep :: PGColumn t a => PGValue -> a+#endif+  pgDecodeRep (PGTextValue v) = pgDecode (PGTypeProxy :: PGTypeName t) v+  pgDecodeRep _ = error $ "pgDecodeRep " ++ pgTypeName (PGTypeProxy :: PGTypeName t) ++ ": unsupported PGValue"++-- |Produce a safely type-cast literal value for interpolation in a SQL statement.+pgSafeLiteral :: PGRep t a => a -> String+pgSafeLiteral x = pgLiteralRep x ++ "::" ++ pgTypeName (pgTypeOf x)++instance PGRep t a => PGRep t (Maybe a) where+  pgEncodeRep Nothing = PGNullValue+  pgEncodeRep (Just x) = pgEncodeRep x+  pgLiteralRep Nothing = "NULL"+  pgLiteralRep (Just x) = pgLiteralRep x+  pgDecodeRep PGNullValue = Nothing+  pgDecodeRep v = Just (pgDecodeRep v)++instance PGRep "boolean" Bool where+instance PGRep "oid" OID where+instance PGRep "smallint" Int16 where+instance PGRep "integer" Int32 where+instance PGRep "bigint" Int64 where+instance PGRep "real" Float where+instance PGRep "double precision" Double where+instance PGRep "\"char\"" Char where+instance PGRep "text" String where+#ifdef USE_TEXT+instance PGRep "text" T.Text where+#endif+instance PGRep "date" Time.Day+instance PGRep "time without time zone" Time.TimeOfDay+instance PGRep "timestamp without time zone" Time.LocalTime+instance PGRep "timestamp with time zone" Time.UTCTime+instance PGRep "interval" Time.DiffTime+instance PGRep "numeric" Rational+#ifdef USE_SCIENTIFIC+instance PGRep "numeric" Scientific where+#endif+#ifdef USE_UUID+instance PGRep "uuid" UUID.UUID where+#endif++-- |Create an expression that literally substitutes each instance of @${expr}@ for the result of @pgSafeLiteral expr@.+-- This lets you do safe, type-driven literal substitution into SQL fragments without needing a full query, bypassing placeholder inference and any prepared queries.+-- Unlike most other TH functions, this does not require any database connection.+pgSubstituteLiterals :: String -> TH.ExpQ+pgSubstituteLiterals ('$':'$':'{':s) = (++$) "${" <$> pgSubstituteLiterals s+pgSubstituteLiterals ('$':'{':s)+  | (e, '}':r) <- break (\c -> c == '{' || c == '}') s = do+    v <- either (fail . (++) ("Failed to parse expression {" ++ e ++ "}: ")) return $ parseExp e+    ($++$) (TH.VarE 'pgSafeLiteral `TH.AppE` v) <$> pgSubstituteLiterals r+  | otherwise = fail $ "Error parsing SQL: could not find end of expression: ${" ++ s+pgSubstituteLiterals (c:r) = (++$) [c] <$> pgSubstituteLiterals r+pgSubstituteLiterals "" = return $ stringE ""
Database/PostgreSQL/Typed/Enum.hs view
@@ -12,20 +12,19 @@ import Control.Monad (when) import qualified Data.ByteString.Char8 as BSC import qualified Data.ByteString.UTF8 as U-import Data.Foldable (toList)-import qualified Data.Sequence as Seq import qualified Language.Haskell.TH as TH  import Database.PostgreSQL.Typed.Protocol import Database.PostgreSQL.Typed.TH import Database.PostgreSQL.Typed.Types+import Database.PostgreSQL.Typed.Dynamic  -- |Create a new enum type corresponding to the given PostgreSQL enum type. -- For example, if you have @CREATE TYPE foo AS ENUM (\'abc\', \'DEF\');@, then -- @makePGEnum \"foo\" \"Foo\" (\"Foo_\"++)@ will be equivalent to: --  -- @--- data Foo = Foo_abc | Foo_DEF deriving (Eq, Ord, Enum, Bounded)+-- data Foo = Foo_abc | Foo_DEF deriving (Eq, Ord, Enum, Bounded, Show, Read) -- instance PGType Foo where ... -- registerPGType \"foo\" (ConT ''Foo) -- @@@ -38,17 +37,18 @@ makePGEnum name typs valnf = do   (_, vals) <- TH.runIO $ withTPGConnection $ \c ->     pgSimpleQuery c $ "SELECT enumlabel FROM pg_catalog.pg_enum JOIN pg_catalog.pg_type t ON enumtypid = t.oid WHERE typtype = 'e' AND format_type(t.oid, -1) = " ++ pgQuote name ++ " ORDER BY enumsortorder"-  when (Seq.null vals) $ fail $ "makePGEnum: enum " ++ name ++ " not found"+  when (null vals) $ fail $ "makePGEnum: enum " ++ name ++ " not found"   let -    valn = map (\[PGTextValue v] -> (TH.StringL (BSC.unpack v), TH.mkName $ valnf (U.toString v))) $ toList vals+    valn = map (\[PGTextValue v] -> (TH.StringL (BSC.unpack v), TH.mkName $ valnf (U.toString v))) vals   dv <- TH.newName "x"   ds <- TH.newName "s"   return-    [ TH.DataD [] typn [] (map (\(_, n) -> TH.NormalC n []) valn) [''Eq, ''Ord, ''Enum, ''Bounded]-    , TH.InstanceD [] (TH.ConT ''PGParameter `TH.AppT` TH.LitT (TH.StrTyLit name) `TH.AppT` typt)+    [ TH.DataD [] typn [] (map (\(_, n) -> TH.NormalC n []) valn) [''Eq, ''Ord, ''Enum, ''Bounded, ''Show, ''Read]+    , TH.InstanceD [] (TH.ConT ''PGType `TH.AppT` typl) []+    , TH.InstanceD [] (TH.ConT ''PGParameter `TH.AppT` typl `TH.AppT` typt)       [ TH.FunD 'pgEncode $ map (\(l, n) -> TH.Clause [TH.WildP, TH.ConP n []]         (TH.NormalB $ TH.VarE 'BSC.pack `TH.AppE` TH.LitE l) []) valn ]-    , TH.InstanceD [] (TH.ConT ''PGColumn `TH.AppT` TH.LitT (TH.StrTyLit name) `TH.AppT` typt)+    , TH.InstanceD [] (TH.ConT ''PGColumn `TH.AppT` typl `TH.AppT` typt)       [ TH.FunD 'pgDecode [TH.Clause [TH.WildP, TH.VarP dv]         (TH.NormalB $ TH.CaseE (TH.VarE 'BSC.unpack `TH.AppE` TH.VarE dv) $ map (\(l, n) ->           TH.Match (TH.LitP l) (TH.NormalB $ TH.ConE n) []) valn ++@@ -56,7 +56,9 @@             TH.InfixE (Just $ TH.LitE (TH.StringL ("pgDecode " ++ name ++ ": "))) (TH.VarE '(++)) (Just $ TH.VarE ds))             []])         []] ]+    , TH.InstanceD [] (TH.ConT ''PGRep `TH.AppT` typl `TH.AppT` typt) []     ]   where   typn = TH.mkName typs   typt = TH.ConT typn+  typl = TH.LitT (TH.StrTyLit name)
+ Database/PostgreSQL/Typed/Internal.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE PatternSynonyms, TemplateHaskell #-}+module Database.PostgreSQL.Typed.Internal+  ( stringE+  , pattern StringE+  , ($++$)+  , (++$)+  ) where++import Data.String (IsString(..))+import qualified Language.Haskell.TH as TH++stringE :: String -> TH.Exp+stringE = TH.LitE . TH.StringL++pattern StringE s = TH.LitE (TH.StringL s)+pattern InfixE l o r = TH.InfixE (Just l) (TH.VarE o) (Just r)++instance IsString TH.Exp where+  fromString = stringE++($++$) :: TH.Exp -> TH.Exp -> TH.Exp+infixr 5 $++$+StringE s $++$ r = s ++$ r+l $++$ StringE "" = l+InfixE ll pp (StringE lr) $++$ StringE r | pp == '(++) = ll $++$ StringE (lr ++ r)+l $++$ r = InfixE l '(++) r++(++$) :: String -> TH.Exp -> TH.Exp+infixr 5 ++$+"" ++$ r = r+l ++$ StringE r = StringE (l ++ r)+l ++$ InfixE (StringE rl) pp rr | pp == '(++) = (l ++ rl) ++$ rr+l ++$ r = InfixE (StringE l) '(++) r
Database/PostgreSQL/Typed/Protocol.hs view
@@ -41,10 +41,10 @@ import qualified Data.ByteString.UTF8 as BSU import qualified Data.Foldable as Fold import Data.IORef (IORef, newIORef, writeIORef, readIORef, atomicModifyIORef, atomicModifyIORef', modifyIORef)+import Data.Int (Int32, Int16) import qualified Data.Map.Lazy as Map import Data.Maybe (fromMaybe) import Data.Monoid (mempty, (<>))-import qualified Data.Sequence as Seq import Data.Typeable (Typeable) import Data.Word (Word32) import Network (HostName, PortID(..), connectTo)@@ -53,19 +53,23 @@ import Text.Read (readMaybe)  import Database.PostgreSQL.Typed.Types+import Database.PostgreSQL.Typed.Dynamic  data PGState-  = StateUnknown+  = StateUnknown -- no Sync+  | StatePending -- Sync sent+  -- ReadyForQuery received:   | StateIdle   | StateTransaction   | StateTransactionFailed+  -- Terminate sent or EOF received   | StateClosed   deriving (Show, Eq)  -- |Information for how to connect to a database, to be passed to 'pgConnect'. data PGDatabase = PGDatabase   { pgDBHost :: HostName -- ^ The hostname (ignored if 'pgDBPort' is 'UnixSocket')-  , pgDBPort :: PortID -- ^ The port, likely either @PortNumber 5432@ or @UnixSocket \"/tmp/.s.PGSQL.5432\"@+  , pgDBPort :: PortID -- ^ The port, likely either @PortNumber 5432@ or @UnixSocket \"\/tmp\/.s.PGSQL.5432\"@   , pgDBName :: String -- ^ The name of the database   , pgDBUser, pgDBPass :: String   , pgDBDebug :: Bool -- ^ Log all low-level server messages@@ -93,9 +97,9 @@ data ColDescription = ColDescription   { colName :: String   , colTable :: !OID-  , colNumber :: !Int+  , colNumber :: !Int16   , colType :: !OID-  , colModifier :: !Word32+  , colModifier :: !Int32   , colBinary :: !Bool   } deriving (Show) @@ -259,7 +263,7 @@ -- |Send a message to PostgreSQL (low-level). pgSend :: PGConnection -> PGFrontendMessage -> IO () pgSend c@PGConnection{ connHandle = h, connState = sr } msg = do-  writeIORef sr StateUnknown+  writeIORef sr (case msg of Sync -> StatePending ; _ -> StateUnknown)   when (connDebug c) $ putStrLn $ "> " ++ show msg   B.hPutBuilder h $ Fold.foldMap B.char7 t <> B.word32BE (fromIntegral $ 4 + BS.length b)   BS.hPut h b -- or B.hPutBuilder? But we've already had to convert to BS to get length@@ -306,7 +310,7 @@       , colTable = oid       , colNumber = fromIntegral col       , colType = typ'-      , colModifier = tmod+      , colModifier = fromIntegral tmod       , colBinary = toEnum (fromIntegral fmt)       } getMessageBody 'Z' = ReadyForQuery <$> (rs . w2c =<< G.getWord8) where@@ -393,7 +397,7 @@         , connParameters = Map.empty         , connPreparedStatements = prep         , connState = state-        , connTypeEnv = undefined+        , connTypeEnv = unknownPGTypeEnv         , connInput = input         }   pgSend c $ StartupMessage@@ -411,7 +415,7 @@   conn c = pgReceive c >>= msg c   msg c (ReadyForQuery _) = return c     { connTypeEnv = PGTypeEnv-      { pgIntegerDatetimes = (connParameters c Map.! "integer_datetimes") == "on"+      { pgIntegerDatetimes = fmap ("on" ==) $ Map.lookup "integer_datetimes" (connParameters c)       }     }   msg c (BackendKeyData p k) = conn c{ connPid = p, connKey = k }@@ -451,8 +455,12 @@ pgSync :: PGConnection -> IO () pgSync c@PGConnection{ connState = sr } = do   s <- readIORef sr-  when (s == StateClosed) $ fail "pgSync: operation on closed connection"-  when (s == StateUnknown) $ wait False where+  case s of+    StateClosed -> fail "pgSync: operation on closed connection"+    StatePending -> wait True+    StateUnknown -> wait False+    _ -> return ()+  where   wait s = do     r <- pgRecv s c     case r of@@ -501,9 +509,9 @@     | nulls && oid /= 0 = do       -- In cases where the resulting field is tracable to the column of a       -- table, we can check there.-      (_, r) <- pgSimpleQuery h ("SELECT attnotnull FROM pg_catalog.pg_attribute WHERE attrelid = " ++ show oid ++ " AND attnum = " ++ show col)-      case Fold.toList r of-        [[PGTextValue s]] -> return $ not $ pgDecode (PGTypeProxy :: PGTypeName "boolean") s+      (_, r) <- pgPreparedQuery h "SELECT attnotnull FROM pg_catalog.pg_attribute WHERE attrelid = $1 AND attnum = $2" [26, 21] [pgEncodeRep (oid :: OID), pgEncodeRep (col :: Int16)] []+      case r of+        [[s]] -> return $ not $ pgDecodeRep s         [] -> return True         _ -> fail $ "Failed to determine nullability of column #" ++ show col     | otherwise = return True@@ -525,21 +533,21 @@ -- cannot bind parameters. Note that queries can return 0 results (an empty -- list). pgSimpleQuery :: PGConnection -> String -- ^ SQL string-                   -> IO (Int, Seq.Seq PGValues) -- ^ The number of rows affected and a list of result rows+                   -> IO (Int, [PGValues]) -- ^ The number of rows affected and a list of result rows pgSimpleQuery h sql = do   pgSync h   pgSend h $ SimpleQuery sql   pgFlush h   go start where    go = (pgReceive h >>=)-  start (RowDescription rd) = go $ row (map colBinary rd) Seq.empty-  start (CommandComplete c) = got c Seq.empty-  start EmptyQueryResponse = return (0, Seq.empty)+  start (RowDescription rd) = go (row (map colBinary rd))+  start (CommandComplete c) = got c+  start EmptyQueryResponse = return (0, [])   start m = fail $ "pgSimpleQuery: unexpected response: " ++ show m-  row bc s (DataRow fs) = go $ row bc (s Seq.|> fixBinary bc fs)-  row _ s (CommandComplete c) = got c s-  row _ _ m = fail $ "pgSimpleQuery: unexpected row: " ++ show m-  got c s = return (rowsAffected c, s)+  row bc (DataRow fs) = second (fixBinary bc fs :) <$> go (row bc)+  row _ (CommandComplete c) = got c+  row _ m = fail $ "pgSimpleQuery: unexpected row: " ++ show m+  got c = return (rowsAffected c, [])  pgPreparedBind :: PGConnection -> String -> [OID] -> PGValues -> [Bool] -> IO (IO ()) pgPreparedBind c@PGConnection{ connPreparedStatements = psr } sql types bind bc = do@@ -567,7 +575,7 @@   -> [OID] -- ^ Optional type specifications (only used for first call)   -> PGValues -- ^ Paremeters to bind to placeholders   -> [Bool] -- ^ Requested binary format for result columns-  -> IO (Int, Seq.Seq PGValues)+  -> IO (Int, [PGValues]) pgPreparedQuery c sql types bind bc = do   start <- pgPreparedBind c sql types bind bc   pgSend c $ Execute 0@@ -575,13 +583,13 @@   pgSend c Sync   pgFlush c   start-  go Seq.empty+  go   where-  go = (pgReceive c >>=) . row-  row s (DataRow fs) = go (s Seq.|> fixBinary bc fs)-  row s (CommandComplete r) = return (rowsAffected r, s)-  row s EmptyQueryResponse = return (0, s)-  row _ m = fail $ "pgPreparedQuery: unexpected row: " ++ show m+  go = pgReceive c >>= row+  row (DataRow fs) = second (fixBinary bc fs :) <$> go+  row (CommandComplete r) = return (rowsAffected r, [])+  row EmptyQueryResponse = return (0, [])+  row m = fail $ "pgPreparedQuery: unexpected row: " ++ show m  -- |Like 'pgPreparedQuery' but requests results lazily in chunks of the given size. -- Does not use a named portal, so other requests may not intervene.@@ -592,18 +600,18 @@   unsafeInterleaveIO $ do     execute     start-    go Seq.empty+    go   where   execute = do     pgSend c $ Execute count     pgSend c $ Flush     pgFlush c-  go = (pgReceive c >>=) . row-  row s (DataRow fs) = go (s Seq.|> fixBinary bc fs)-  row s PortalSuspended = (Fold.toList s ++) <$> unsafeInterleaveIO (execute >> go Seq.empty)-  row s (CommandComplete _) = return $ Fold.toList s-  row s EmptyQueryResponse = return $ Fold.toList s-  row _ m = fail $ "pgPreparedLazyQuery: unexpected row: " ++ show m+  go = pgReceive c >>= row+  row (DataRow fs) = (fixBinary bc fs :) <$> go+  row PortalSuspended = unsafeInterleaveIO (execute >> go)+  row (CommandComplete _) = return []+  row EmptyQueryResponse = return []+  row m = fail $ "pgPreparedLazyQuery: unexpected row: " ++ show m  -- |Close a previously prepared query (if necessary). pgCloseStatement :: PGConnection -> String -> [OID] -> IO ()
Database/PostgreSQL/Typed/Query.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE PatternGuards, MultiParamTypeClasses, FunctionalDependencies, TypeSynonymInstances, FlexibleInstances, FlexibleContexts, TemplateHaskell #-}+{-# LANGUAGE CPP, PatternGuards, MultiParamTypeClasses, FunctionalDependencies, TypeSynonymInstances, FlexibleInstances, FlexibleContexts, TemplateHaskell #-} module Database.PostgreSQL.Typed.Query   ( PGQuery(..)   , PGSimpleQuery@@ -6,7 +6,7 @@   , rawPGSimpleQuery   , rawPGPreparedQuery   , QueryFlags(..)-  , simpleFlags+  , simpleQueryFlags   , makePGQuery   , pgSQL   , pgExecute@@ -20,33 +20,33 @@ import Control.Monad (when, mapAndUnzipM) import Data.Array (listArray, (!), inRange) import Data.Char (isDigit, isSpace)-import Data.Foldable (toList) import Data.List (dropWhileEnd) import Data.Maybe (fromMaybe, isNothing)-import Data.Sequence (Seq) import Data.Word (Word32) import Language.Haskell.Meta.Parse (parseExp) import qualified Language.Haskell.TH as TH import Language.Haskell.TH.Quote (QuasiQuoter(..)) import Numeric (readDec) +import Database.PostgreSQL.Typed.Internal import Database.PostgreSQL.Typed.Types+import Database.PostgreSQL.Typed.Dynamic import Database.PostgreSQL.Typed.Protocol import Database.PostgreSQL.Typed.TH  class PGQuery q a | q -> a where   -- |Execute a query and return the number of rows affected (or -1 if not known) and a list of results.-  pgRunQuery :: PGConnection -> q -> IO (Int, Seq a)+  pgRunQuery :: PGConnection -> q -> IO (Int, [a]) class PGQuery q PGValues => PGRawQuery q --- |Execute a query that does not return result.+-- |Execute a query that does not return results. -- Return the number of rows affected (or -1 if not known). pgExecute :: PGQuery q () => PGConnection -> q -> IO Int pgExecute c q = fst <$> pgRunQuery c q  -- |Run a query and return a list of row results. pgQuery :: PGQuery q a => PGConnection -> q -> IO [a]-pgQuery c q = toList . snd <$> pgRunQuery c q+pgQuery c q = snd <$> pgRunQuery c q   data SimpleQuery = SimpleQuery String@@ -110,28 +110,16 @@ -- |Given a SQL statement with placeholders of the form @$N@ and a list of TH 'String' expressions, return a new 'String' expression that substitutes the expressions for the placeholders. -- This does not understand strings or other SQL syntax, so any literal occurrence of a string like @$N@ must be escaped as @$$N@. sqlSubstitute :: String -> [TH.Exp] -> TH.Exp-sqlSubstitute sql exprl = se sql where+sqlSubstitute sql exprl = ss sql where   bnds = (1, length exprl)   exprs = listArray bnds exprl   expr n     | inRange bnds n = exprs ! n     | otherwise = error $ "SQL placeholder '$" ++ show n ++ "' out of range (not recognized by PostgreSQL); literal occurrences may need to be escaped with '$$'"--  se = uncurry ((+$+) . stringL) . ss-  ss ('$':'$':d:r) | isDigit d = first (('$':) . (d:)) $ ss r-  ss ('$':s@(d:_)) | isDigit d, [(n, r)] <- readDec s = ("", expr n +$+ se r)-  ss (c:r) = first (c:) $ ss r-  ss "" = ("", stringL "")--stringL :: String -> TH.Exp-stringL = TH.LitE . TH.StringL--(+$+) :: TH.Exp -> TH.Exp -> TH.Exp-infixr 5 +$+-TH.LitE (TH.StringL "") +$+ e = e-e +$+ TH.LitE (TH.StringL "") = e-TH.LitE (TH.StringL l) +$+ TH.LitE (TH.StringL r) = stringL (l ++ r)-l +$+ r = TH.InfixE (Just l) (TH.VarE '(++)) (Just r)+  ss ('$':'$':d:r) | isDigit d = ['$',d] ++$ ss r+  ss ('$':s@(d:_)) | isDigit d, [(n, r)] <- readDec s = expr n $++$ ss r+  ss (c:r) = [c] ++$ ss r+  ss "" = stringE ""  splitCommas :: String -> [String] splitCommas = spl where@@ -143,46 +131,64 @@ trim :: String -> String trim = dropWhileEnd isSpace . dropWhile isSpace --- |Flags affecting how and what type of query to build with 'makeQuery'.+-- |Flags affecting how and what type of query to build with 'makePGQuery'. data QueryFlags = QueryFlags-  { flagNullable :: Bool -- ^ Assume all results are nullable and don't try to guess.+  { flagQuery :: Bool -- ^ Create a query -- otherwise just call 'pgSubstituteLiterals' to create a string (SQL fragment)+  , flagNullable :: Bool -- ^ Assume all results are nullable and don't try to guess.   , flagPrepare :: Maybe [String] -- ^ Prepare and re-use query, binding parameters of the given types (inferring the rest, like PREPARE).   }  -- |'QueryFlags' for a default (simple) query.-simpleFlags :: QueryFlags-simpleFlags = QueryFlags False Nothing+simpleQueryFlags :: QueryFlags+simpleQueryFlags = QueryFlags True False Nothing  -- |Construct a 'PGQuery' from a SQL string. makePGQuery :: QueryFlags -> String -> TH.ExpQ+makePGQuery QueryFlags{ flagQuery = False } sqle = pgSubstituteLiterals sqle makePGQuery QueryFlags{ flagNullable = nulls, flagPrepare = prep } sqle = do-  (pt, rt) <- tpgDescribe sqlp (fromMaybe [] prep) (not nulls)+  (pt, rt) <- TH.runIO $ tpgDescribe sqlp (fromMaybe [] prep) (not nulls)   when (length pt < length exprs) $ fail "Not all expression placeholders were recognized by PostgreSQL; literal occurrences of '${' may need to be escaped with '$${'" -  e <- TH.newName "tenv"+  e <- TH.newName "_tenv"   (vars, vals) <- mapAndUnzipM (\t -> do     v <- TH.newName $ 'p':tpgValueName t-    return (TH.VarP v, tpgTypeEncoder (isNothing prep) t e v)) pt-  (pats, conv, bc) <- unzip3 <$> mapM (\t -> do+    return +      ( TH.VarP v+      , tpgTypeEncoder (isNothing prep) t e `TH.AppE` TH.VarE v+      )) pt+  (pats, conv, bins) <- unzip3 <$> mapM (\t -> do     v <- TH.newName $ 'c':tpgValueName t-    return (TH.VarP v, tpgTypeDecoder t e v, tpgValueBinary t)) rt-  let pgq-        | isNothing prep = TH.ConE 'SimpleQuery `TH.AppE` sqlSubstitute sqlp vals-        | otherwise = TH.ConE 'PreparedQuery `TH.AppE` stringL sqlp `TH.AppE` TH.ListE (map (TH.LitE . TH.IntegerL . toInteger . tpgValueTypeOID) pt) `TH.AppE` TH.ListE vals `TH.AppE` TH.ListE (map boolL bc)+    return +      ( TH.VarP v+      , tpgTypeDecoder t e `TH.AppE` TH.VarE v+      , tpgTypeBinary t e+      )) rt   foldl TH.AppE (TH.LamE vars $ TH.ConE 'QueryParser-    `TH.AppE` TH.LamE [TH.VarP e] pgq+    `TH.AppE` TH.LamE [TH.VarP e] (if isNothing prep+      then TH.ConE 'SimpleQuery+        `TH.AppE` sqlSubstitute sqlp vals+      else TH.ConE 'PreparedQuery+        `TH.AppE` stringE sqlp +        `TH.AppE` TH.ListE (map (TH.LitE . TH.IntegerL . toInteger . tpgValueTypeOID) pt) +        `TH.AppE` TH.ListE vals +        `TH.AppE` TH.ListE +#ifdef USE_BINARY+          bins+#else+          []+#endif+      )     `TH.AppE` TH.LamE [TH.VarP e, TH.ListP pats] (TH.TupE conv))     <$> mapM parse exprs   where   (sqlp, exprs) = sqlPlaceholders sqle   parse e = either (fail . (++) ("Failed to parse expression {" ++ e ++ "}: ")) return $ parseExp e-  boolL False = TH.ConE 'False-  boolL True = TH.ConE 'True  qqQuery :: QueryFlags -> String -> TH.ExpQ-qqQuery f@QueryFlags{ flagNullable = False } ('?':q) = qqQuery f{ flagNullable = True } q-qqQuery f@QueryFlags{ flagPrepare = Nothing } ('$':q) = qqQuery f{ flagPrepare = Just [] } q-qqQuery f@QueryFlags{ flagPrepare = Just [] } ('(':s) = qqQuery f{ flagPrepare = Just args } =<< sql r where+qqQuery f@QueryFlags{ flagQuery = True, flagPrepare = Nothing } ('#':q) = qqQuery f{ flagQuery = False } q+qqQuery f@QueryFlags{ flagQuery = True, flagNullable = False } ('?':q) = qqQuery f{ flagNullable = True } q+qqQuery f@QueryFlags{ flagQuery = True, flagPrepare = Nothing } ('$':q) = qqQuery f{ flagPrepare = Just [] } q+qqQuery f@QueryFlags{ flagQuery = True, flagPrepare = Just [] } ('(':s) = qqQuery f{ flagPrepare = Just args } =<< sql r where   args = map trim $ splitCommas arg   (arg, r) = break (')' ==) s   sql (')':q) = return q@@ -203,6 +209,7 @@ -- The statement may contain PostgreSQL-style placeholders (@$1@, @$2@, ...) or in-line placeholders (@${1+1}@) containing any valid Haskell expression (except @{}@). -- It will be replaced by a 'PGQuery' object that can be used to perform the SQL statement. -- If there are more @$N@ placeholders than expressions, it will instead be a function accepting the additional parameters and returning a 'PGQuery'.+--  -- Note that all occurrences of @$N@ or @${@ will be treated as placeholders, regardless of their context in the SQL (e.g., even within SQL strings or other places placeholders are disallowed by PostgreSQL), which may cause invalid SQL or other errors. -- If you need to pass a literal @$@ through in these contexts, you may double it to escape it as @$$N@ or @$${@. --@@ -211,12 +218,13 @@ -- [@?@] To disable nullability inference, treating all result values as nullable, thus returning 'Maybe' values regardless of inferred nullability. -- [@$@] To create a 'PGPreparedQuery' rather than a 'PGSimpleQuery', by default inferring parameter types. -- [@$(type,...)@] To specify specific types to a prepared query (see <http://www.postgresql.org/docs/current/static/sql-prepare.html> for details).+-- [@#@] Only do literal @${}@ substitution using 'pgSubstituteLiterals' and return a string, not a query. -- --- This can also be used at the top-level to execute SQL statements at compile-time (without any parameters and ignoring results).+-- 'pgSQL' can also be used at the top-level to execute SQL statements at compile-time (without any parameters and ignoring results). -- Here the query can only be prefixed with @!@ to make errors non-fatal. pgSQL :: QuasiQuoter pgSQL = QuasiQuoter-  { quoteExp = qqQuery simpleFlags+  { quoteExp = qqQuery simpleQueryFlags   , quoteType = const $ fail "pgSQL not supported in types"   , quotePat = const $ fail "pgSQL not supported in patterns"   , quoteDec = qqTop True
Database/PostgreSQL/Typed/Range.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, UndecidableInstances, FunctionalDependencies, DataKinds #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module: Database.PostgreSQL.Typed.Range -- Copyright: 2015 Dylan Simon@@ -8,10 +10,15 @@  module Database.PostgreSQL.Typed.Range where -import Control.Applicative ((<$))+import Control.Applicative ((<$>), (<$)) import Control.Monad (guard)-import Data.Monoid ((<>))+import qualified Data.ByteString.Builder as BSB+import qualified Data.ByteString.Char8 as BSC+import Data.Monoid ((<>), mempty)+import qualified Text.Parsec as P +import Database.PostgreSQL.Typed.Types+ data Bound a   = Unbounded   | Bounded Bool a@@ -139,3 +146,52 @@ intersect :: Ord a => Range a -> Range a -> Range a intersect (Range la ua) (Range lb ub) = normalize $ Range (max la lb) (min ua ub) intersect _ _ = Empty+++-- |Class indicating that the first PostgreSQL type is a range of the second.+-- This implies 'PGParameter' and 'PGColumn' instances that will work for any type.+class (PGType tr, PGType t) => PGRangeType tr t | tr -> t where+  pgRangeElementType :: PGTypeName tr -> PGTypeName t+  pgRangeElementType PGTypeProxy = PGTypeProxy++instance (PGRangeType tr t, PGParameter t a) => PGParameter tr (Range a) where+  pgEncode _ Empty = BSC.pack "empty"+  pgEncode tr (Range (Lower l) (Upper u)) = buildPGValue $+    pc '[' '(' l+      <> pb (bound l)+      <> BSB.char7 ','+      <> pb (bound u)+      <> pc ']' ')' u+    where+    pb Nothing = mempty+    pb (Just b) = pgDQuote "(),[]" $ pgEncode (pgRangeElementType tr) b+    pc c o b = BSB.char7 $ if boundClosed b then c else o+instance (PGRangeType tr t, PGColumn t a) => PGColumn tr (Range a) where+  pgDecode tr = either (error . ("pgDecode range: " ++) . show) id . P.parse per "range" where+    per = Empty <$ pe P.<|> pr+    pe = P.oneOf "Ee" >> P.oneOf "Mm" >> P.oneOf "Pp" >> P.oneOf "Tt" >> P.oneOf "Yy"+    pp = pgDecode (pgRangeElementType tr) . BSC.pack <$> parsePGDQuote "(),[]"+    pc c o = True <$ P.char c P.<|> False <$ P.char o+    pb = P.optionMaybe $ P.between P.spaces P.spaces $ pp+    mb = maybe Unbounded . Bounded+    pr = do+      lc <- pc '[' '('+      lb <- pb+      _ <- P.char ','+      ub <- pb +      uc <- pc ']' ')'+      return $ Range (Lower (mb lc lb)) (Upper (mb uc ub))++instance PGType "int4range"+instance PGRangeType "int4range" "integer"+instance PGType "numrange"+instance PGRangeType "numrange" "numeric"+instance PGType "tsrange"+instance PGRangeType "tsrange" "timestamp without time zone"+instance PGType "tstzrange"+instance PGRangeType "tstzrange" "timestamp with time zone"+instance PGType "daterange"+instance PGRangeType "daterange" "date"+instance PGType "int8range"+instance PGRangeType "int8range" "bigint"+
Database/PostgreSQL/Typed/TH.hs view
@@ -15,6 +15,7 @@   , tpgDescribe   , tpgTypeEncoder   , tpgTypeDecoder+  , tpgTypeBinary   ) where  import Control.Applicative ((<$>), (<$), (<|>))@@ -32,6 +33,7 @@ import System.IO.Unsafe (unsafePerformIO, unsafeInterleaveIO)  import Database.PostgreSQL.Typed.Types+import Database.PostgreSQL.Typed.Dynamic import Database.PostgreSQL.Typed.Protocol  -- |A particular PostgreSQL type, identified by full formatted name (from @format_type@ or @\\dT@).@@ -57,9 +59,11 @@     , pgDBDebug = debug     } +{-# NOINLINE tpgState #-} tpgState :: MVar (PGDatabase, Maybe TPGState)-tpgState = unsafePerformIO $-  newMVar (unsafePerformIO getTPGDatabase, Nothing)+tpgState = unsafePerformIO $ do+  db <- unsafeInterleaveIO getTPGDatabase+  newMVar (db, Nothing)  data TPGState = TPGState   { tpgConnection :: PGConnection@@ -70,8 +74,8 @@ tpgLoadTypes tpg = do   -- defer loading types until they're needed   tl <- unsafeInterleaveIO $ pgSimpleQuery (tpgConnection tpg) "SELECT typ.oid, format_type(CASE WHEN typtype = 'd' THEN typbasetype ELSE typ.oid END, -1) FROM pg_catalog.pg_type typ JOIN pg_catalog.pg_namespace nsp ON typnamespace = nsp.oid WHERE nspname <> 'pg_toast' AND nspname <> 'information_schema' ORDER BY typ.oid"-  return $ tpg{ tpgTypes = IntMap.fromAscList $ map (\[PGTextValue to, PGTextValue tn] ->-    (fromIntegral (pgDecode (PGTypeProxy :: PGTypeName "oid") to :: OID), pgDecode (PGTypeProxy :: PGTypeName "text") tn)) $ Fold.toList $ snd tl+  return $ tpg{ tpgTypes = IntMap.fromAscList $ map (\[to, tn] ->+    (fromIntegral (pgDecodeRep to :: OID), pgDecodeRep tn)) $ snd tl   }  tpgInit :: PGConnection -> IO TPGState@@ -124,69 +128,53 @@   maybe (fail $ "Unknown PostgreSQL type: " ++ t ++ "; be sure to use the exact type name from \\dTS") (return . fromIntegral . fst)     $ find ((==) t . snd) $ IntMap.toList types --- |Determine if a type supports binary format marshalling.--- Checks for a 'PGBinaryType' instance.  Should be efficient.-tpgTypeIsBinary :: TPGType -> TH.Q Bool-tpgTypeIsBinary t =-  TH.isInstance ''PGBinaryType [TH.LitT (TH.StrTyLit t)]- data TPGValueInfo = TPGValueInfo   { tpgValueName :: String   , tpgValueTypeOID :: !OID   , tpgValueType :: TPGType-  , tpgValueBinary :: Bool   , tpgValueNullable :: Bool   }  -- |A type-aware wrapper to 'pgDescribe'-tpgDescribe :: String -> [String] -> Bool -> TH.Q ([TPGValueInfo], [TPGValueInfo])-tpgDescribe sql types nulls = do-  (pv, rv) <- TH.runIO $ withTPGState $ \tpg -> do-    at <- mapM (getTPGTypeOID tpg) types-    (pt, rt) <- pgDescribe (tpgConnection tpg) sql at nulls-    return-      ( map (\o -> TPGValueInfo-        { tpgValueName = ""-        , tpgValueTypeOID = o-        , tpgValueType = tpgType tpg o-        , tpgValueBinary = False-        , tpgValueNullable = True-        }) pt-      , map (\(c, o, n) -> TPGValueInfo-        { tpgValueName = c-        , tpgValueTypeOID = o-        , tpgValueType = tpgType tpg o-        , tpgValueBinary = False-        , tpgValueNullable = n-        }) rt-      )-#ifdef USE_BINARY-  -- now that we're back in Q (and have given up the TPGState) we go back to fill in binary:-  liftM2 (,) (fillBin pv) (fillBin rv)-  where-  fillBin = mapM (\i -> do-    b <- tpgTypeIsBinary (tpgValueType i)-    return i{ tpgValueBinary = b })-#else-  return (pv, rv)-#endif-+tpgDescribe :: String -> [String] -> Bool -> IO ([TPGValueInfo], [TPGValueInfo])+tpgDescribe sql types nulls = withTPGState $ \tpg -> do+  at <- mapM (getTPGTypeOID tpg) types+  (pt, rt) <- pgDescribe (tpgConnection tpg) sql at nulls+  return+    ( map (\o -> TPGValueInfo+      { tpgValueName = ""+      , tpgValueTypeOID = o+      , tpgValueType = tpgType tpg o+      , tpgValueNullable = True+      }) pt+    , map (\(c, o, n) -> TPGValueInfo+      { tpgValueName = c+      , tpgValueTypeOID = o+      , tpgValueType = tpgType tpg o+      , tpgValueNullable = n+      }) rt+    ) -typeApply :: TPGType -> TH.Name -> TH.Name -> TH.Name -> TH.Exp-typeApply t f e v =+typeApply :: TPGType -> TH.Name -> TH.Name -> TH.Exp+typeApply t f e =   TH.VarE f `TH.AppE` TH.VarE e     `TH.AppE` (TH.ConE 'PGTypeProxy `TH.SigE` (TH.ConT ''PGTypeName `TH.AppT` TH.LitT (TH.StrTyLit t)))-    `TH.AppE` TH.VarE v   -- |TH expression to encode a 'PGParameter' value to a 'Maybe' 'L.ByteString'.-tpgTypeEncoder :: Bool -> TPGValueInfo -> TH.Name -> TH.Name -> TH.Exp-tpgTypeEncoder lit v = typeApply (tpgValueType v) $ if lit-  then 'pgEscapeParameter-  else if tpgValueBinary v then 'pgEncodeBinaryParameter else 'pgEncodeParameter+tpgTypeEncoder :: Bool -> TPGValueInfo -> TH.Name -> TH.Exp+tpgTypeEncoder lit v = typeApply (tpgValueType v) $+  if lit+    then 'pgEscapeParameter+    else 'pgEncodeParameter  -- |TH expression to decode a 'Maybe' 'L.ByteString' to a ('Maybe') 'PGColumn' value.-tpgTypeDecoder :: TPGValueInfo -> TH.Name -> TH.Name -> TH.Exp-tpgTypeDecoder v = typeApply (tpgValueType v) $ if tpgValueBinary v-  then if tpgValueNullable v then 'pgDecodeBinaryColumn else 'pgDecodeBinaryColumnNotNull-  else if tpgValueNullable v then 'pgDecodeColumn       else 'pgDecodeColumnNotNull+tpgTypeDecoder :: TPGValueInfo -> TH.Name -> TH.Exp+tpgTypeDecoder v = typeApply (tpgValueType v) $+  if tpgValueNullable v+    then 'pgDecodeColumn+    else 'pgDecodeColumnNotNull++-- |TH expression calling 'pgBinaryColumn'.+tpgTypeBinary :: TPGValueInfo -> TH.Name -> TH.Exp+tpgTypeBinary v = typeApply (tpgValueType v) 'pgBinaryColumn
Database/PostgreSQL/Typed/TemplatePG.hs view
@@ -44,10 +44,9 @@ --  -- Example (where @h@ is a handle from 'pgConnect'): -- --- @$(queryTuples \"SELECT usesysid, usename FROM pg_user\") h :: IO [(Maybe String, Maybe Integer)]--- @+-- > $(queryTuples "SELECT usesysid, usename FROM pg_user") h :: IO [(Maybe String, Maybe Integer)] queryTuples :: String -> TH.ExpQ-queryTuples sql = [| \c -> pgQuery c $(makePGQuery simpleFlags $ querySQL sql) |]+queryTuples sql = [| \c -> pgQuery c $(makePGQuery simpleQueryFlags $ querySQL sql) |]  -- |@queryTuple :: String -> (PGConnection -> IO (Maybe (column1, column2, ...)))@ -- @@ -56,10 +55,8 @@ --  -- Example (where @h@ is a handle from 'pgConnect'): -- --- @let sysid = 10::Integer;--- --- $(queryTuple \"SELECT usesysid, usename FROM pg_user WHERE usesysid = {sysid}\") h :: IO (Maybe (Maybe String, Maybe Integer))--- @+-- > let sysid = 10::Integer;+-- > $(queryTuple "SELECT usesysid, usename FROM pg_user WHERE usesysid = {sysid}") h :: IO (Maybe (Maybe String, Maybe Integer)) queryTuple :: String -> TH.ExpQ queryTuple sql = [| liftM listToMaybe . $(queryTuples sql) |] @@ -68,13 +65,8 @@ -- Convenience function to execute a statement on the PostgreSQL server. --  -- Example (where @h@ is a handle from 'pgConnect'):--- --- @let rolename = \"BOfH\"--- --- $(execute \"CREATE ROLE {rolename}\") h--- @ execute :: String -> TH.ExpQ-execute sql = [| \c -> void $ pgExecute c $(makePGQuery simpleFlags $ querySQL sql) |]+execute sql = [| \c -> void $ pgExecute c $(makePGQuery simpleQueryFlags $ querySQL sql) |]  -- |Run a sequence of IO actions (presumably SQL statements) wrapped in a -- transaction. Unfortunately you're restricted to using this in the 'IO'
Database/PostgreSQL/Typed/Types.hs view
@@ -11,28 +11,26 @@     OID   , PGValue(..)   , PGValues-  , pgQuote   , PGTypeName(..)   , PGTypeEnv(..)+  , unknownPGTypeEnv    -- * Marshalling classes+  , PGType(..)   , PGParameter(..)-  , PGBinaryParameter   , PGColumn(..)-  , PGBinaryType -  -- * Marshalling utilities+  -- * Marshalling interface   , pgEncodeParameter-  , pgEncodeBinaryParameter   , pgEscapeParameter   , pgDecodeColumn   , pgDecodeColumnNotNull-  , pgDecodeBinaryColumn-  , pgDecodeBinaryColumnNotNull -  -- * Specific type support-  , PGArrayType-  , PGRangeType+  -- * Conversion utilities+  , pgQuote+  , pgDQuote+  , parsePGDQuote+  , buildPGValue   ) where  import Control.Applicative ((<$>), (<$))@@ -48,7 +46,7 @@ import qualified Data.ByteString.UTF8 as BSU import Data.Char (isSpace, isDigit, digitToInt, intToDigit, toLower) import Data.Int-import Data.List (intersperse)+import Data.List (intersperse, intercalate) import Data.Maybe (fromMaybe) import Data.Monoid ((<>), mconcat, mempty) import Data.Ratio ((%), numerator, denominator)@@ -77,113 +75,96 @@ import qualified Text.Parsec as P import Text.Parsec.Token (naturalOrFloat, makeTokenParser, GenLanguageDef(..)) -import qualified Database.PostgreSQL.Typed.Range as Range- type PGTextValue = BS.ByteString type PGBinaryValue = BS.ByteString -- |A value passed to or from PostgreSQL in raw format. data PGValue   = PGNullValue-  | PGTextValue PGTextValue -- ^ The standard text encoding format (also used for unknown formats)-  | PGBinaryValue PGBinaryValue -- ^ Special binary-encoded data.  Not supported in all cases.+  | PGTextValue { pgTextValue :: PGTextValue } -- ^ The standard text encoding format (also used for unknown formats)+  | PGBinaryValue { pgBinaryValue :: PGBinaryValue } -- ^ Special binary-encoded data.  Not supported in all cases.   deriving (Show, Eq) -- |A list of (nullable) data values, e.g. a single row or query parameters. type PGValues = [PGValue] --- |A proxy type for PostgreSQL types.  The type argument should be an (internal) name of a database type (see @\\dT+@).-data PGTypeName (t :: Symbol) = PGTypeProxy--class KnownSymbol t => PGBinaryType t--pgTypeName :: KnownSymbol t => PGTypeName (t :: Symbol) -> String-pgTypeName = symbolVal- -- |Parameters that affect how marshalling happens. -- Currenly we force all other relevant parameters at connect time.+-- Nothing values represent unknown. data PGTypeEnv = PGTypeEnv-  { pgIntegerDatetimes :: Bool -- ^ If @integer_datetimes@ is @on@; only relevant for binary encoding.+  { pgIntegerDatetimes :: Maybe Bool -- ^ If @integer_datetimes@ is @on@; only relevant for binary encoding.   } +unknownPGTypeEnv :: PGTypeEnv+unknownPGTypeEnv = PGTypeEnv+  { pgIntegerDatetimes = Nothing+  }++-- |A proxy type for PostgreSQL types.  The type argument should be an (internal) name of a database type (see @\\dT+@).+data PGTypeName (t :: Symbol) = PGTypeProxy++-- |A valid PostgreSQL type.+-- This is just an indicator class: no implementation is needed.+-- Unfortunately this will generate orphan instances wherever used.+class KnownSymbol t => PGType t where+  pgTypeName :: PGTypeName t -> String+  pgTypeName = symbolVal+  -- |Does this type support binary decoding?+  -- If so, 'pgDecodeBinary' must be implemented for every 'PGColumn' instance of this type.+  pgBinaryColumn :: PGTypeEnv -> PGTypeName t -> Bool+  pgBinaryColumn _ _ = False+ -- |A @PGParameter t a@ instance describes how to encode a PostgreSQL type @t@ from @a@.-class KnownSymbol t => PGParameter (t :: Symbol) a where+class PGType t => PGParameter t a where   -- |Encode a value to a PostgreSQL text representation.   pgEncode :: PGTypeName t -> a -> PGTextValue   -- |Encode a value to a (quoted) literal value for use in SQL statements.   -- Defaults to a quoted version of 'pgEncode'   pgLiteral :: PGTypeName t -> a -> String   pgLiteral t = pgQuote . BSU.toString . pgEncode t-class (PGParameter t a, PGBinaryType t) => PGBinaryParameter t a where-  pgEncodeBinary :: PGTypeEnv -> PGTypeName t -> a -> PGBinaryValue+  -- |Encode a value to a PostgreSQL representation.+  -- Defaults to the text representation by pgEncode+  pgEncodeValue :: PGTypeEnv -> PGTypeName t -> a -> PGValue+  pgEncodeValue _ t = PGTextValue . pgEncode t  -- |A @PGColumn t a@ instance describes how te decode a PostgreSQL type @t@ to @a@.-class KnownSymbol t => PGColumn (t :: Symbol) a where+class PGType t => PGColumn t a where   -- |Decode the PostgreSQL text representation into a value.   pgDecode :: PGTypeName t -> PGTextValue -> a-class (PGColumn t a, PGBinaryType t) => PGBinaryColumn t a where+  -- |Decode the PostgreSQL binary representation into a value.+  -- Only needs to be implemented if 'pgBinaryColumn' is true.   pgDecodeBinary :: PGTypeEnv -> PGTypeName t -> PGBinaryValue -> a---- |Support encoding of 'Maybe' values into NULL.-class PGParameterNull t a where-  pgEncodeNull :: PGTypeName t -> a -> PGValue-  pgLiteralNull :: PGTypeName t -> a -> String-class PGParameterNull t a => PGBinaryParameterNull t a where-  pgEncodeBinaryNull :: PGTypeEnv -> PGTypeName t -> a -> PGValue---- |Support decoding of assumed non-null columns but also still allow decoding into 'Maybe'.-class PGColumnNotNull t a where-  pgDecodeNotNull :: PGTypeName t -> PGValue -> a-+  pgDecodeBinary _ t _ = error $ "pgDecodeBinary " ++ pgTypeName t ++ ": not supported"+  pgDecodeValue :: PGTypeEnv -> PGTypeName t -> PGValue -> a+  pgDecodeValue _ t (PGTextValue v) = pgDecode t v+  pgDecodeValue e t (PGBinaryValue v) = pgDecodeBinary e t v+  pgDecodeValue _ t PGNullValue = error $ "NULL in " ++ pgTypeName t ++ " column (use Maybe or COALESCE)" -instance PGParameter t a => PGParameterNull t a where-  pgEncodeNull t = PGTextValue . pgEncode t-  pgLiteralNull = pgLiteral-instance PGParameter t a => PGParameterNull t (Maybe a) where-  pgEncodeNull t = maybe PGNullValue (PGTextValue . pgEncode t)-  pgLiteralNull = maybe "NULL" . pgLiteral-instance PGBinaryParameter t a => PGBinaryParameterNull t a where-  pgEncodeBinaryNull e t = PGBinaryValue . pgEncodeBinary e t-instance PGBinaryParameter t a => PGBinaryParameterNull t (Maybe a) where-  pgEncodeBinaryNull e t = maybe PGNullValue (PGBinaryValue . pgEncodeBinary e t)+instance PGParameter t a => PGParameter t (Maybe a) where+  pgEncode t = maybe (error $ "pgEncode " ++ pgTypeName t ++ ": Nothing") (pgEncode t)+  pgLiteral = maybe "NULL" . pgLiteral+  pgEncodeValue e = maybe PGNullValue . pgEncodeValue e -instance PGColumn t a => PGColumnNotNull t a where-  pgDecodeNotNull t PGNullValue = error $ "NULL in " ++ pgTypeName t ++ " column (use Maybe or COALESCE)"-  pgDecodeNotNull t (PGTextValue v) = pgDecode t v-  pgDecodeNotNull t (PGBinaryValue _) = error $ "pgDecode: unexpected binary value in " ++ pgTypeName t-instance PGColumn t a => PGColumnNotNull t (Maybe a) where-  pgDecodeNotNull _ PGNullValue = Nothing-  pgDecodeNotNull t (PGTextValue v) = Just $ pgDecode t v-  pgDecodeNotNull t (PGBinaryValue _) = error $ "pgDecode: unexpected binary value in " ++ pgTypeName t+instance PGColumn t a => PGColumn t (Maybe a) where+  pgDecode t = Just . pgDecode t+  pgDecodeBinary e t = Just . pgDecodeBinary e t+  pgDecodeValue _ _ PGNullValue = Nothing+  pgDecodeValue e t v = Just $ pgDecodeValue e t v   -- |Final parameter encoding function used when a (nullable) parameter is passed to a prepared query.-pgEncodeParameter :: PGParameterNull t a => PGTypeEnv -> PGTypeName t -> a -> PGValue-pgEncodeParameter _ = pgEncodeNull---- |Final parameter encoding function used when a (nullable) parameter is passed to a prepared query accepting binary-encoded data.-pgEncodeBinaryParameter :: PGBinaryParameterNull t a => PGTypeEnv -> PGTypeName t -> a -> PGValue-pgEncodeBinaryParameter = pgEncodeBinaryNull+pgEncodeParameter :: PGParameter t a => PGTypeEnv -> PGTypeName t -> a -> PGValue+pgEncodeParameter = pgEncodeValue  -- |Final parameter escaping function used when a (nullable) parameter is passed to be substituted into a simple query.-pgEscapeParameter :: PGParameterNull t a => PGTypeEnv -> PGTypeName t -> a -> String-pgEscapeParameter _ = pgLiteralNull+pgEscapeParameter :: PGParameter t a => PGTypeEnv -> PGTypeName t -> a -> String+pgEscapeParameter _ = pgLiteral  -- |Final column decoding function used for a nullable result value.-pgDecodeColumn :: PGColumnNotNull t (Maybe a) => PGTypeEnv -> PGTypeName t -> PGValue -> Maybe a-pgDecodeColumn _ = pgDecodeNotNull+pgDecodeColumn :: PGColumn t (Maybe a) => PGTypeEnv -> PGTypeName t -> PGValue -> Maybe a+pgDecodeColumn = pgDecodeValue  -- |Final column decoding function used for a non-nullable result value.-pgDecodeColumnNotNull :: PGColumnNotNull t a => PGTypeEnv -> PGTypeName t -> PGValue -> a-pgDecodeColumnNotNull _ = pgDecodeNotNull---- |Final column decoding function used for a nullable binary-encoded result value.-pgDecodeBinaryColumn :: PGBinaryColumn t a => PGTypeEnv -> PGTypeName t -> PGValue -> Maybe a-pgDecodeBinaryColumn e t (PGBinaryValue v) = Just $ pgDecodeBinary e t v-pgDecodeBinaryColumn e t v = pgDecodeColumn e t v---- |Final column decoding function used for a non-nullable binary-encoded result value.-pgDecodeBinaryColumnNotNull :: (PGColumnNotNull t a, PGBinaryColumn t a) => PGTypeEnv -> PGTypeName t -> PGValue -> a-pgDecodeBinaryColumnNotNull e t (PGBinaryValue v) = pgDecodeBinary e t v-pgDecodeBinaryColumnNotNull _ t v = pgDecodeNotNull t v+pgDecodeColumnNotNull :: PGColumn t a => PGTypeEnv -> PGTypeName t -> PGValue -> a+pgDecodeColumnNotNull = pgDecodeValue   pgQuoteUnsafe :: String -> String@@ -196,13 +177,13 @@   es (c@'\'':r) = c:c:es r   es (c:r) = c:es r -buildBS :: BSB.Builder -> BS.ByteString-buildBS = BSL.toStrict . BSB.toLazyByteString+buildPGValue :: BSB.Builder -> BS.ByteString+buildPGValue = BSL.toStrict . BSB.toLazyByteString  -- |Double-quote a value if it's \"\", \"null\", or contains any whitespace, \'\"\', \'\\\', or the characters given in the first argument. -- Checking all these things may not be worth it.  We could just double-quote everything.-dQuote :: String -> BS.ByteString -> BSB.Builder-dQuote unsafe s+pgDQuote :: String -> BS.ByteString -> BSB.Builder+pgDQuote unsafe s   | BS.null s || BSC.any (\c -> isSpace c || c == '"' || c == '\\' || c `elem` unsafe) s || BSC.map toLower s == BSC.pack "null" =     dq <> BSBP.primMapByteStringBounded ec s <> dq   | otherwise = BSB.byteString s where@@ -210,84 +191,155 @@   ec = BSBP.condB (\c -> c == c2w '"' || c == c2w '\\') bs (BSBP.liftFixedToBounded BSBP.word8)   bs = BSBP.liftFixedToBounded $ ((,) '\\') BSBP.>$< (BSBP.char7 BSBP.>*< BSBP.word8) -parseDQuote :: P.Stream s m Char => String -> P.ParsecT s u m String-parseDQuote unsafe = (q P.<|> uq) where+-- |Parse double-quoted values ala 'pgDQuote'.+parsePGDQuote :: P.Stream s m Char => String -> P.ParsecT s u m String+parsePGDQuote unsafe = (q P.<|> uq) where   q = P.between (P.char '"') (P.char '"') $     P.many $ (P.char '\\' >> P.anyChar) P.<|> P.noneOf "\\\""   uq = P.many1 (P.noneOf ('"':'\\':unsafe)) --class (Show a, Read a, KnownSymbol t) => PGLiteralType t a+#ifdef USE_BINARY+binDec :: PGType t => BinD.D a -> PGTypeName t -> PGBinaryValue -> a+binDec d t = either (\e -> error $ "pgDecodeBinary " ++ pgTypeName t ++ ": " ++ show e) id . d -instance PGLiteralType t a => PGParameter t a where-  pgEncode _ = BSC.pack . show-  pgLiteral _ = show-instance PGLiteralType t a => PGColumn t a where-  pgDecode _ = read . BSC.unpack+#define BIN_COL pgBinaryColumn _ _ = True+#define BIN_ENC(F) pgEncodeValue _ _ = PGBinaryValue . F+#define BIN_DEC(F) pgDecodeBinary _ = F+#else+#define BIN_COL+#define BIN_ENC(F)+#define BIN_DEC(F)+#endif +instance PGType "boolean" where BIN_COL instance PGParameter "boolean" Bool where   pgEncode _ False = BSC.singleton 'f'   pgEncode _ True = BSC.singleton 't'   pgLiteral _ False = "false"   pgLiteral _ True = "true"+  BIN_ENC(BinE.bool) instance PGColumn "boolean" Bool where   pgDecode _ s = case BSC.head s of     'f' -> False     't' -> True     c -> error $ "pgDecode boolean: " ++ [c]+  BIN_DEC(binDec BinD.bool)  type OID = Word32-instance PGLiteralType "oid" OID-instance PGLiteralType "smallint" Int16-instance PGLiteralType "integer" Int32-instance PGLiteralType "bigint" Int64-instance PGLiteralType "real" Float-instance PGLiteralType "double precision" Double+instance PGType "oid" where BIN_COL+instance PGParameter "oid" OID where+  pgEncode _ = BSC.pack . show+  pgLiteral _ = show+  BIN_ENC(BinE.int4 . Right)+instance PGColumn "oid" OID where+  pgDecode _ = read . BSC.unpack+  BIN_DEC(binDec BinD.int) +instance PGType "smallint" where BIN_COL+instance PGParameter "smallint" Int16 where+  pgEncode _ = BSC.pack . show+  pgLiteral _ = show+  BIN_ENC(BinE.int2. Left)+instance PGColumn "smallint" Int16 where+  pgDecode _ = read . BSC.unpack+  BIN_DEC(binDec BinD.int) +instance PGType "integer" where BIN_COL+instance PGParameter "integer" Int32 where+  pgEncode _ = BSC.pack . show+  pgLiteral _ = show+  BIN_ENC(BinE.int4 . Left)+instance PGColumn "integer" Int32 where+  pgDecode _ = read . BSC.unpack+  BIN_DEC(binDec BinD.int)++instance PGType "bigint" where BIN_COL+instance PGParameter "bigint" Int64 where+  pgEncode _ = BSC.pack . show+  pgLiteral _ = show+  BIN_ENC(BinE.int8 . Left)+instance PGColumn "bigint" Int64 where+  pgDecode _ = read . BSC.unpack+  BIN_DEC(binDec BinD.int)++instance PGType "real" where BIN_COL+instance PGParameter "real" Float where+  pgEncode _ = BSC.pack . show+  pgLiteral _ = show+  BIN_ENC(BinE.float4)+instance PGColumn "real" Float where+  pgDecode _ = read . BSC.unpack+  BIN_DEC(binDec BinD.float4)++instance PGType "double precision" where BIN_COL+instance PGParameter "double precision" Double where+  pgEncode _ = BSC.pack . show+  pgLiteral _ = show+  BIN_ENC(BinE.float8)+instance PGColumn "double precision" Double where+  pgDecode _ = read . BSC.unpack+  BIN_DEC(binDec BinD.float8)++instance PGType "\"char\"" where BIN_COL instance PGParameter "\"char\"" Char where   pgEncode _ = BSC.singleton+  BIN_ENC(BinE.char) instance PGColumn "\"char\"" Char where   pgDecode _ = BSC.head+  BIN_DEC(binDec BinD.char)  -class KnownSymbol t => PGStringType t+class PGType t => PGStringType t  instance PGStringType t => PGParameter t String where   pgEncode _ = BSU.fromString+  BIN_ENC(BinE.text . Left . T.pack) instance PGStringType t => PGColumn t String where   pgDecode _ = BSU.toString+  BIN_DEC((T.unpack .) . binDec BinD.text)  instance PGStringType t => PGParameter t BS.ByteString where   pgEncode _ = id+  BIN_ENC(BinE.text . Left . TE.decodeUtf8) instance PGStringType t => PGColumn t BS.ByteString where   pgDecode _ = id+  BIN_DEC((TE.encodeUtf8 .) . binDec BinD.text)  instance PGStringType t => PGParameter t BSL.ByteString where   pgEncode _ = BSL.toStrict+  BIN_ENC(BinE.text . Right . TLE.decodeUtf8) instance PGStringType t => PGColumn t BSL.ByteString where   pgDecode _ = BSL.fromStrict+  BIN_DEC((BSL.fromStrict .) . (TE.encodeUtf8 .) . binDec BinD.text)  #ifdef USE_TEXT instance PGStringType t => PGParameter t T.Text where   pgEncode _ = TE.encodeUtf8+  BIN_ENC(BinE.text . Left) instance PGStringType t => PGColumn t T.Text where   pgDecode _ = TE.decodeUtf8+  BIN_DEC(binDec BinD.text)  instance PGStringType t => PGParameter t TL.Text where   pgEncode _ = BSL.toStrict . TLE.encodeUtf8+  BIN_ENC(BinE.text . Right) instance PGStringType t => PGColumn t TL.Text where   pgDecode _ = TL.fromStrict . TE.decodeUtf8+  BIN_DEC((TL.fromStrict .) . binDec BinD.text) #endif +instance PGType "text" where BIN_COL+instance PGType "character varying" where BIN_COL+instance PGType "name" where BIN_COL+instance PGType "bpchar" where BIN_COL instance PGStringType "text" instance PGStringType "character varying"-instance PGStringType "name" -- limit 63 characters+instance PGStringType "name" -- limit 63 characters; not strictly textsend but essentially the same instance PGStringType "bpchar" -- blank padded   encodeBytea :: BSB.Builder -> PGTextValue-encodeBytea h = buildBS $ BSB.string7 "\\x" <> h+encodeBytea h = buildPGValue $ BSB.string7 "\\x" <> h  decodeBytea :: PGTextValue -> [Word8] decodeBytea s@@ -300,34 +352,72 @@   pd [x] = error $ "pgDecode bytea: " ++ show x   unhex = fromIntegral . digitToInt . w2c +instance PGType "bytea" where BIN_COL instance PGParameter "bytea" BSL.ByteString where   pgEncode _ = encodeBytea . BSB.lazyByteStringHex   pgLiteral t = pgQuoteUnsafe . BSC.unpack . pgEncode t+  BIN_ENC(BinE.bytea . Right) instance PGColumn "bytea" BSL.ByteString where   pgDecode _ = BSL.pack . decodeBytea+  BIN_DEC((BSL.fromStrict .) . binDec BinD.bytea) instance PGParameter "bytea" BS.ByteString where   pgEncode _ = encodeBytea . BSB.byteStringHex   pgLiteral t = pgQuoteUnsafe . BSC.unpack . pgEncode t+  BIN_ENC(BinE.bytea . Left) instance PGColumn "bytea" BS.ByteString where   pgDecode _ = BS.pack . decodeBytea+  BIN_DEC(binDec BinD.bytea) +instance PGType "date" where BIN_COL instance PGParameter "date" Time.Day where   pgEncode _ = BSC.pack . Time.showGregorian   pgLiteral _ = pgQuoteUnsafe . Time.showGregorian+  BIN_ENC(BinE.date) instance PGColumn "date" Time.Day where   pgDecode _ = Time.readTime defaultTimeLocale "%F" . BSC.unpack+  BIN_DEC(binDec BinD.date) +binColDatetime :: PGTypeEnv -> PGTypeName t -> Bool+#ifdef USE_BINARY+binColDatetime PGTypeEnv{ pgIntegerDatetimes = Just _ } _ = True+#endif+binColDatetime _ _ = False++#ifdef USE_BINARY+binEncDatetime :: PGParameter t a => (Bool -> a -> PGBinaryValue) -> PGTypeEnv -> PGTypeName t -> a -> PGValue+binEncDatetime f e t = maybe (PGTextValue . pgEncode t) ((PGBinaryValue .) . f) (pgIntegerDatetimes e)++binDecDatetime :: PGColumn t a => (Bool -> BinD.D a) -> PGTypeEnv -> PGTypeName t -> PGBinaryValue -> a+binDecDatetime f e = binDec $ f $ fromMaybe (error "pgDecodeBinary: unknown integer_datetimes value") $ pgIntegerDatetimes e+#endif++instance PGType "time without time zone" where+  pgBinaryColumn = binColDatetime instance PGParameter "time without time zone" Time.TimeOfDay where   pgEncode _ = BSC.pack . Time.formatTime defaultTimeLocale "%T%Q"   pgLiteral _ = pgQuoteUnsafe . Time.formatTime defaultTimeLocale "%T%Q"+#ifdef USE_BINARY+  pgEncodeValue = binEncDatetime BinE.time+#endif instance PGColumn "time without time zone" Time.TimeOfDay where   pgDecode _ = Time.readTime defaultTimeLocale "%T%Q" . BSC.unpack+#ifdef USE_BINARY+  pgDecodeBinary = binDecDatetime BinD.time+#endif +instance PGType "timestamp without time zone" where+  pgBinaryColumn = binColDatetime instance PGParameter "timestamp without time zone" Time.LocalTime where   pgEncode _ = BSC.pack . Time.formatTime defaultTimeLocale "%F %T%Q"   pgLiteral _ = pgQuoteUnsafe . Time.formatTime defaultTimeLocale "%F %T%Q"+#ifdef USE_BINARY+  pgEncodeValue = binEncDatetime BinE.timestamp+#endif instance PGColumn "timestamp without time zone" Time.LocalTime where   pgDecode _ = Time.readTime defaultTimeLocale "%F %T%Q" . BSC.unpack+#ifdef USE_BINARY+  pgDecodeBinary = binDecDatetime BinD.timestamp+#endif  -- PostgreSQL uses "[+-]HH[:MM]" timezone offsets, while "%z" uses "+HHMM" by default. -- readTime can successfully parse both formats, but PostgreSQL needs the colon.@@ -339,15 +429,28 @@ fixTZ ['-',h1,h2,m1,m2] | isDigit h1 && isDigit h2 && isDigit m1 && isDigit m2 = ['-',h1,h2,':',m1,m2] fixTZ (c:s) = c:fixTZ s +instance PGType "timestamp with time zone" where+  pgBinaryColumn = binColDatetime instance PGParameter "timestamp with time zone" Time.UTCTime where   pgEncode _ = BSC.pack . fixTZ . Time.formatTime defaultTimeLocale "%F %T%Q%z"   pgLiteral _ = pgQuote{-Unsafe-} . fixTZ . Time.formatTime defaultTimeLocale "%F %T%Q%z"+#ifdef USE_BINARY+  pgEncodeValue = binEncDatetime BinE.timestamptz+#endif instance PGColumn "timestamp with time zone" Time.UTCTime where   pgDecode _ = Time.readTime defaultTimeLocale "%F %T%Q%z" . fixTZ . BSC.unpack+#ifdef USE_BINARY+  pgDecodeBinary = binDecDatetime BinD.timestamptz+#endif +instance PGType "interval" where+  pgBinaryColumn = binColDatetime instance PGParameter "interval" Time.DiffTime where   pgEncode _ = BSC.pack . show   pgLiteral _ = pgQuoteUnsafe . show+#ifdef USE_BINARY+  pgEncodeValue = binEncDatetime BinE.interval+#endif -- |Representation of DiffTime as interval. -- PostgreSQL stores months and days separately in intervals, but DiffTime does not. -- We collapse all interval fields into seconds@@ -382,7 +485,11 @@       , reservedNames  = []       , caseSensitive  = True       }+#ifdef USE_BINARY+  pgDecodeBinary = binDecDatetime BinD.interval+#endif +instance PGType "numeric" where BIN_COL instance PGParameter "numeric" Rational where   pgEncode _ r     | denominator r == 0 = BSC.pack "NaN" -- this can't happen@@ -391,6 +498,7 @@   pgLiteral _ r     | denominator r == 0 = "'NaN'" -- this can't happen     | otherwise = '(' : show (numerator r) ++ '/' : show (denominator r) ++ "::numeric)"+  BIN_ENC(BinE.numeric . realToFrac) -- |High-precision representation of Rational as numeric. -- Unfortunately, numeric has an NaN, while Rational does not. -- NaN numeric values will produce exceptions.@@ -401,6 +509,7 @@     ur [(x,"")] = x     ur _ = error $ "pgDecode numeric: " ++ s     s = BSC.unpack bs+  BIN_DEC((realToFrac .) . binDec BinD.numeric)  -- This will produce infinite(-precision) strings showRational :: Rational -> String@@ -410,288 +519,47 @@   frac f = intToDigit i : frac f' where (i, f') = properFraction (10 * f)  #ifdef USE_SCIENTIFIC-instance PGLiteralType "numeric" Scientific+instance PGParameter "numeric" Scientific where+  pgEncode _ = BSC.pack . show+  pgLiteral _ = show+  BIN_ENC(BinE.numeric)+instance PGColumn "numeric" Scientific where+  pgDecode _ = read . BSC.unpack+  BIN_DEC(binDec BinD.numeric) #endif --- |The cannonical representation of a PostgreSQL array of any type, which may always contain NULLs.--- Currenly only one-dimetional arrays are supported, although in PostgreSQL, any array may be of any dimentionality.-type PGArray a = [Maybe a]---- |Class indicating that the first PostgreSQL type is an array of the second.--- This implies 'PGParameter' and 'PGColumn' instances that will work for any type using comma as a delimiter (i.e., anything but @box@).--- This will only work with 1-dimensional arrays.-class (KnownSymbol ta, KnownSymbol t) => PGArrayType ta t | ta -> t, t -> ta where-  pgArrayElementType :: PGTypeName ta -> PGTypeName t-  pgArrayElementType PGTypeProxy = PGTypeProxy-  -- |The character used as a delimeter.  The default @,@ is correct for all standard types (except @box@).-  pgArrayDelim :: PGTypeName ta -> Char-  pgArrayDelim _ = ','--instance (PGArrayType ta t, PGParameter t a) => PGParameter ta (PGArray a) where-  pgEncode ta l = buildBS $ BSB.char7 '{' <> mconcat (intersperse (BSB.char7 $ pgArrayDelim ta) $ map el l) <> BSB.char7 '}' where-    el Nothing = BSB.string7 "null"-    el (Just e) = dQuote (pgArrayDelim ta : "{}") $ pgEncode (pgArrayElementType ta) e-instance (PGArrayType ta t, PGColumn t a) => PGColumn ta (PGArray a) where-  pgDecode ta = either (error . ("pgDecode array: " ++) . show) id . P.parse pa "array" where-    pa = do-      l <- P.between (P.char '{') (P.char '}') $-        P.sepBy nel (P.char (pgArrayDelim ta))-      _ <- P.eof-      return l-    nel = P.between P.spaces P.spaces $ Nothing <$ nul P.<|> Just <$> el-    nul = P.oneOf "Nn" >> P.oneOf "Uu" >> P.oneOf "Ll" >> P.oneOf "Ll"-    el = pgDecode (pgArrayElementType ta) . BSC.pack <$> parseDQuote (pgArrayDelim ta : "{}")---- Just a dump of pg_type:-instance PGArrayType "boolean[]"       "boolean"-instance PGArrayType "bytea[]"         "bytea"-instance PGArrayType "\"char\"[]"      "\"char\""-instance PGArrayType "name[]"          "name"-instance PGArrayType "bigint[]"        "bigint"-instance PGArrayType "smallint[]"      "smallint"-instance PGArrayType "int2vector[]"    "int2vector"-instance PGArrayType "integer[]"       "integer"-instance PGArrayType "regproc[]"       "regproc"-instance PGArrayType "text[]"          "text"-instance PGArrayType "oid[]"           "oid"-instance PGArrayType "tid[]"           "tid"-instance PGArrayType "xid[]"           "xid"-instance PGArrayType "cid[]"           "cid"-instance PGArrayType "oidvector[]"     "oidvector"-instance PGArrayType "json[]"          "json"-instance PGArrayType "xml[]"           "xml"-instance PGArrayType "point[]"         "point"-instance PGArrayType "lseg[]"          "lseg"-instance PGArrayType "path[]"          "path"-instance PGArrayType "box[]"           "box" where-  pgArrayDelim _ = ';'-instance PGArrayType "polygon[]"       "polygon"-instance PGArrayType "line[]"          "line"-instance PGArrayType "cidr[]"          "cidr"-instance PGArrayType "real[]"          "real"-instance PGArrayType "double precision[]"            "double precision"-instance PGArrayType "abstime[]"       "abstime"-instance PGArrayType "reltime[]"       "reltime"-instance PGArrayType "tinterval[]"     "tinterval"-instance PGArrayType "circle[]"        "circle"-instance PGArrayType "money[]"         "money"-instance PGArrayType "macaddr[]"       "macaddr"-instance PGArrayType "inet[]"          "inet"-instance PGArrayType "aclitem[]"       "aclitem"-instance PGArrayType "bpchar[]"        "bpchar"-instance PGArrayType "character varying[]"           "character varying"-instance PGArrayType "date[]"          "date"-instance PGArrayType "time without time zone[]"      "time without time zone"-instance PGArrayType "timestamp without time zone[]" "timestamp without time zone"-instance PGArrayType "timestamp with time zone[]"    "timestamp with time zone"-instance PGArrayType "interval[]"      "interval"-instance PGArrayType "time with time zone[]"         "time with time zone"-instance PGArrayType "bit[]"           "bit"-instance PGArrayType "varbit[]"        "varbit"-instance PGArrayType "numeric[]"       "numeric"-instance PGArrayType "refcursor[]"     "refcursor"-instance PGArrayType "regprocedure[]"  "regprocedure"-instance PGArrayType "regoper[]"       "regoper"-instance PGArrayType "regoperator[]"   "regoperator"-instance PGArrayType "regclass[]"      "regclass"-instance PGArrayType "regtype[]"       "regtype"-instance PGArrayType "record[]"        "record"-instance PGArrayType "cstring[]"       "cstring"-instance PGArrayType "uuid[]"          "uuid"-instance PGArrayType "txid_snapshot[]" "txid_snapshot"-instance PGArrayType "tsvector[]"      "tsvector"-instance PGArrayType "tsquery[]"       "tsquery"-instance PGArrayType "gtsvector[]"     "gtsvector"-instance PGArrayType "regconfig[]"     "regconfig"-instance PGArrayType "regdictionary[]" "regdictionary"-instance PGArrayType "int4range[]"     "int4range"-instance PGArrayType "numrange[]"      "numrange"-instance PGArrayType "tsrange[]"       "tsrange"-instance PGArrayType "tstzrange[]"     "tstzrange"-instance PGArrayType "daterange[]"     "daterange"-instance PGArrayType "int8range[]"     "int8range"----- |Class indicating that the first PostgreSQL type is a range of the second.--- This implies 'PGParameter' and 'PGColumn' instances that will work for any type.-class (KnownSymbol tr, KnownSymbol t) => PGRangeType tr t | tr -> t where-  pgRangeElementType :: PGTypeName tr -> PGTypeName t-  pgRangeElementType PGTypeProxy = PGTypeProxy--instance (PGRangeType tr t, PGParameter t a) => PGParameter tr (Range.Range a) where-  pgEncode _ Range.Empty = BSC.pack "empty"-  pgEncode tr (Range.Range (Range.Lower l) (Range.Upper u)) = buildBS $-    pc '[' '(' l-      <> pb (Range.bound l)-      <> BSB.char7 ','-      <> pb (Range.bound u)-      <> pc ']' ')' u-    where-    pb Nothing = mempty-    pb (Just b) = dQuote "(),[]" $ pgEncode (pgRangeElementType tr) b-    pc c o b = BSB.char7 $ if Range.boundClosed b then c else o-instance (PGRangeType tr t, PGColumn t a) => PGColumn tr (Range.Range a) where-  pgDecode tr = either (error . ("pgDecode range: " ++) . show) id . P.parse per "range" where-    per = Range.Empty <$ pe P.<|> pr-    pe = P.oneOf "Ee" >> P.oneOf "Mm" >> P.oneOf "Pp" >> P.oneOf "Tt" >> P.oneOf "Yy"-    pp = pgDecode (pgRangeElementType tr) . BSC.pack <$> parseDQuote "(),[]"-    pc c o = True <$ P.char c P.<|> False <$ P.char o-    pb = P.optionMaybe $ P.between P.spaces P.spaces $ pp-    mb = maybe Range.Unbounded . Range.Bounded-    pr = do-      lc <- pc '[' '('-      lb <- pb-      _ <- P.char ','-      ub <- pb -      uc <- pc ']' ')'-      return $ Range.Range (Range.Lower (mb lc lb)) (Range.Upper (mb uc ub))--instance PGRangeType "int4range" "integer"-instance PGRangeType "numrange" "numeric"-instance PGRangeType "tsrange" "timestamp without time zone"-instance PGRangeType "tstzrange" "timestamp with time zone"-instance PGRangeType "daterange" "date"-instance PGRangeType "int8range" "bigint"- #ifdef USE_UUID+instance PGType "uuid" where BIN_COL instance PGParameter "uuid" UUID.UUID where   pgEncode _ = UUID.toASCIIBytes   pgLiteral _ = pgQuoteUnsafe . UUID.toString+  BIN_ENC(BinE.uuid) instance PGColumn "uuid" UUID.UUID where   pgDecode _ u = fromMaybe (error $ "pgDecode uuid: " ++ BSC.unpack u) $ UUID.fromASCIIBytes u+  BIN_DEC(binDec BinD.uuid) #endif -#ifdef USE_BINARY-binDec :: KnownSymbol t => BinD.D a -> PGTypeName t -> PGBinaryValue -> a-binDec d t = either (\e -> error $ "pgDecodeBinary " ++ pgTypeName t ++ ": " ++ show e) id . d--instance PGBinaryType "oid"-instance PGBinaryParameter "oid" OID where-  pgEncodeBinary _ _ = BinE.int4 . Right-instance PGBinaryColumn "oid" OID where-  pgDecodeBinary _ = binDec BinD.int--instance PGBinaryType "smallint"-instance PGBinaryParameter "smallint" Int16 where-  pgEncodeBinary _ _ = BinE.int2 . Left-instance PGBinaryColumn "smallint" Int16 where-  pgDecodeBinary _ = binDec BinD.int--instance PGBinaryType "integer"-instance PGBinaryParameter "integer" Int32 where-  pgEncodeBinary _ _ = BinE.int4 . Left-instance PGBinaryColumn "integer" Int32 where-  pgDecodeBinary _ = binDec BinD.int--instance PGBinaryType "bigint"-instance PGBinaryParameter "bigint" Int64 where-  pgEncodeBinary _ _ = BinE.int8 . Left-instance PGBinaryColumn "bigint" Int64 where-  pgDecodeBinary _ = binDec BinD.int--instance PGBinaryType "real"-instance PGBinaryParameter "real" Float where-  pgEncodeBinary _ _ = BinE.float4-instance PGBinaryColumn "real" Float where-  pgDecodeBinary _ = binDec BinD.float4--instance PGBinaryType "double precision"-instance PGBinaryParameter "double precision" Double where-  pgEncodeBinary _ _ = BinE.float8-instance PGBinaryColumn "double precision" Double where-  pgDecodeBinary _ = binDec BinD.float8--instance PGBinaryType "numeric"-instance PGBinaryParameter "numeric" Scientific where-  pgEncodeBinary _ _ = BinE.numeric-instance PGBinaryColumn "numeric" Scientific where-  pgDecodeBinary _ = binDec BinD.numeric-instance PGBinaryParameter "numeric" Rational where-  pgEncodeBinary _ _ = BinE.numeric . realToFrac-instance PGBinaryColumn "numeric" Rational where-  pgDecodeBinary _ t = realToFrac . binDec BinD.numeric t--instance PGBinaryType "\"char\""-instance PGBinaryParameter "\"char\"" Char where-  pgEncodeBinary _ _ = BinE.char-instance PGBinaryColumn "\"char\"" Char where-  pgDecodeBinary _ = binDec BinD.char--instance PGBinaryType "text"-instance PGBinaryType "character varying"-instance PGBinaryType "bpchar"-instance PGBinaryType "name" -- not strictly textsend, but essentially the same-instance (PGStringType t, PGBinaryType t) => PGBinaryParameter t T.Text where-  pgEncodeBinary _ _ = BinE.text . Left-instance (PGStringType t, PGBinaryType t) => PGBinaryColumn t T.Text where-  pgDecodeBinary _ = binDec BinD.text-instance (PGStringType t, PGBinaryType t) => PGBinaryParameter t TL.Text where-  pgEncodeBinary _ _ = BinE.text . Right-instance (PGStringType t, PGBinaryType t) => PGBinaryColumn t TL.Text where-  pgDecodeBinary _ t = TL.fromStrict . binDec BinD.text t-instance (PGStringType t, PGBinaryType t) => PGBinaryParameter t BS.ByteString where-  pgEncodeBinary _ _ = BinE.text . Left . TE.decodeUtf8-instance (PGStringType t, PGBinaryType t) => PGBinaryColumn t BS.ByteString where-  pgDecodeBinary _ t = TE.encodeUtf8 . binDec BinD.text t-instance (PGStringType t, PGBinaryType t) => PGBinaryParameter t BSL.ByteString where-  pgEncodeBinary _ _ = BinE.text . Right . TLE.decodeUtf8-instance (PGStringType t, PGBinaryType t) => PGBinaryColumn t BSL.ByteString where-  pgDecodeBinary _ t = BSL.fromStrict . TE.encodeUtf8 . binDec BinD.text t-instance (PGStringType t, PGBinaryType t) => PGBinaryParameter t String where-  pgEncodeBinary _ _ = BinE.text . Left . T.pack-instance (PGStringType t, PGBinaryType t) => PGBinaryColumn t String where-  pgDecodeBinary _ t = T.unpack . binDec BinD.text t--instance PGBinaryType "bytea"-instance PGBinaryParameter "bytea" BS.ByteString where-  pgEncodeBinary _ _ = BinE.bytea . Left-instance PGBinaryColumn "bytea" BS.ByteString where-  pgDecodeBinary _ = binDec BinD.bytea-instance PGBinaryParameter "bytea" BSL.ByteString where-  pgEncodeBinary _ _ = BinE.bytea . Right-instance PGBinaryColumn "bytea" BSL.ByteString where-  pgDecodeBinary _ t = BSL.fromStrict . binDec BinD.bytea t--instance PGBinaryType "date"-instance PGBinaryParameter "date" Time.Day where-  pgEncodeBinary _ _ = BinE.date-instance PGBinaryColumn "date" Time.Day where-  pgDecodeBinary _ = binDec BinD.date-instance PGBinaryType "time without time zone"-instance PGBinaryParameter "time without time zone" Time.TimeOfDay where-  pgEncodeBinary e _ = BinE.time (pgIntegerDatetimes e)-instance PGBinaryColumn "time without time zone" Time.TimeOfDay where-  pgDecodeBinary e = binDec $ BinD.time (pgIntegerDatetimes e)-instance PGBinaryType "timestamp without time zone"-instance PGBinaryParameter "timestamp without time zone" Time.LocalTime where-  pgEncodeBinary e _ = BinE.timestamp (pgIntegerDatetimes e)-instance PGBinaryColumn "timestamp without time zone" Time.LocalTime where-  pgDecodeBinary e = binDec $ BinD.timestamp (pgIntegerDatetimes e)-instance PGBinaryType "timestamp with time zone"-instance PGBinaryParameter "timestamp with time zone" Time.UTCTime where-  pgEncodeBinary e _ = BinE.timestamptz (pgIntegerDatetimes e)-instance PGBinaryColumn "timestamp with time zone" Time.UTCTime where-  pgDecodeBinary e = binDec $ BinD.timestamptz (pgIntegerDatetimes e)-instance PGBinaryType "interval"-instance PGBinaryParameter "interval" Time.DiffTime where-  pgEncodeBinary e _ = BinE.interval (pgIntegerDatetimes e)-instance PGBinaryColumn "interval" Time.DiffTime where-  pgDecodeBinary e = binDec $ BinD.interval (pgIntegerDatetimes e)--instance PGBinaryType "boolean"-instance PGBinaryParameter "boolean" Bool where-  pgEncodeBinary _ _ = BinE.bool-instance PGBinaryColumn "boolean" Bool where-  pgDecodeBinary _ = binDec BinD.bool--instance PGBinaryType "uuid"-instance PGBinaryParameter "uuid" UUID.UUID where-  pgEncodeBinary _ _ = BinE.uuid-instance PGBinaryColumn "uuid" UUID.UUID where-  pgDecodeBinary _ = binDec BinD.uuid+-- |Generic class of composite (row or record) types.+class PGType t => PGRecordType t+instance PGRecordType t => PGParameter t [Maybe PGTextValue] where+  pgEncode _ l =+    buildPGValue $ BSB.char7 '(' <> mconcat (intersperse (BSB.char7 ',') $ map (maybe mempty (pgDQuote "(),")) l) <> BSB.char7 ')' where+  pgLiteral _ l =+    "ROW(" ++ intercalate "," (map (maybe "NULL" (pgQuote . BSU.toString)) l) ++ ")" where+instance PGRecordType t => PGColumn t [Maybe PGTextValue] where+  pgDecode _ = either (error . ("pgDecode record: " ++) . show) id . P.parse pa "record" where+    pa = do+      l <- P.between (P.char '(') (P.char ')') $+        P.sepBy nel (P.char ',')+      _ <- P.eof+      return l+    nel = P.optionMaybe $ P.between P.spaces P.spaces el+    el = BSC.pack <$> parsePGDQuote "()," --- TODO: arrays (a bit complicated, need OID?, but theoretically possible)-#endif+instance PGType "record"+-- |The generic anonymous record type, as created by @ROW@.+-- In this case we can not know the types, and in fact, PostgreSQL does not accept values of this type regardless (except as literals).+instance PGRecordType "record"  {- --, ( 114,  199, "json",        ?)
postgresql-typed.cabal view
@@ -1,5 +1,5 @@ Name:          postgresql-typed-Version:       0.3.0+Version:       0.3.1 Cabal-Version: >= 1.8 License:       BSD3 License-File:  COPYING@@ -12,7 +12,7 @@ Category:      Database Synopsis:      A PostgreSQL access library with compile-time SQL type inference Description:   Automatically type-check SQL statements at compile time.-               Uses Template Haskell and the raw PostgreSQL protocol to describe SQL statement at compile time and provide appropriate type marshalling for both parameters and results.+               Uses Template Haskell and the raw PostgreSQL protocol to describe SQL statements at compile time and provide appropriate type marshalling for both parameters and results.                Allows not only syntax verification of your SQL but also full type safety between your SQL and Haskell.                Supports many built-in PostgreSQL types already, including arrays and ranges, and can be easily extended in user code to support any other types.                Originally based on Chris Forno's templatepg library.@@ -60,8 +60,12 @@     Database.PostgreSQL.Typed.TH     Database.PostgreSQL.Typed.Query     Database.PostgreSQL.Typed.Enum+    Database.PostgreSQL.Typed.Array     Database.PostgreSQL.Typed.Range+    Database.PostgreSQL.Typed.Dynamic     Database.PostgreSQL.Typed.TemplatePG+  Other-Modules:+    Database.PostgreSQL.Typed.Internal   GHC-Options: -Wall   if flag(md5)     Build-Depends: cryptohash >= 0.5
test/Main.hs view
@@ -8,6 +8,7 @@  import Database.PostgreSQL.Typed import Database.PostgreSQL.Typed.Types (OID)+import Database.PostgreSQL.Typed.Array () import qualified Database.PostgreSQL.Typed.Range as Range import Database.PostgreSQL.Typed.Enum @@ -57,6 +58,8 @@   ["box"] <- preparedApply c 603   [Just "line"] <- prepared c 628 "line"   ["line"] <- preparedApply c 628++  assert $ [pgSQL|#abc${f}def|] == "abc3.14::realdef"    pgDisconnect c   exitSuccess