postgresql-simple 0.6 → 0.6.1
raw patch · 20 files changed
+1068/−246 lines, 20 filesdep +cryptohash-md5dep +inspection-testingdep −cryptohashdep ~basedep ~postgresql-libpq
Dependencies added: cryptohash-md5, inspection-testing
Dependencies removed: cryptohash
Dependency ranges changed: base, postgresql-libpq
Files
- CHANGES.md +24/−3
- postgresql-simple.cabal +20/−4
- src/Database/PostgreSQL/Simple.hs +18/−8
- src/Database/PostgreSQL/Simple/Arrays.hs +2/−2
- src/Database/PostgreSQL/Simple/Copy.hs +1/−1
- src/Database/PostgreSQL/Simple/Cursor.hs +5/−5
- src/Database/PostgreSQL/Simple/FromField.hs +58/−45
- src/Database/PostgreSQL/Simple/FromRow.hs +19/−2
- src/Database/PostgreSQL/Simple/HStore/Implementation.hs +3/−3
- src/Database/PostgreSQL/Simple/Internal.hs +22/−6
- src/Database/PostgreSQL/Simple/Internal/PQResultUtils.hs +2/−2
- src/Database/PostgreSQL/Simple/Range.hs +6/−6
- src/Database/PostgreSQL/Simple/SqlQQ.hs +9/−8
- src/Database/PostgreSQL/Simple/ToField.hs +3/−3
- src/Database/PostgreSQL/Simple/ToRow.hs +16/−0
- src/Database/PostgreSQL/Simple/TypeInfo.hs +9/−9
- src/Database/PostgreSQL/Simple/TypeInfo/Macro.hs +9/−3
- src/Database/PostgreSQL/Simple/TypeInfo/Static.hs +684/−114
- test/Inspection.hs +74/−0
- test/Main.hs +84/−22
CHANGES.md view
@@ -1,7 +1,28 @@-### Version 0.6 (2018-09-25)+### Version 0.6.1 (2019-03-04) - * *Breaking change*: Use `Only` package's `Only for a common 1-tuple.+ * Escape double '??' to a literal '?+ Thanks to Felix Paulusma for the implementation.+ https://github.com/phadej/postgresql-simple/pull/5 + * Mention GHC Generics support in the documentation.+ Thanks to Gabriel Gonzalez for the implementation.+ https://github.com/phadej/postgresql-simple/pull/6++ * Better error message for "Query resulted in a command response+ Thanks to Max Amanshauser for the implementation.+ https://github.com/phadej/postgresql-simple/pull/7++ * fromJSONField: Include JSONPath on JSON parse errors+ Thanks to Simon Hengel for the implementation.+ https://github.com/phadej/postgresql-simple/pull/2++ * No TH in implementation+ https://github.com/phadej/postgresql-simple/pull/4++### Version 0.6 (2018-10-16)++ * *Breaking change*: Use `Only` package's `Only` for a common 1-tuple.+ Consider a downstream library depending already both on `Only` and `postgresql-simple` package. This library my define a `MyClass` with instances for `Only.Only` and `PostgreSQL.Only`.@@ -316,7 +337,7 @@ * De-emphasized connect and ConnectInfo in favor of connectPostgreSQL. ### Version 0.4.2.2 (2014-05-15)- * Fixed compatibility with scientific-0.3.*, thanks to Adam Bergmark+ * Fixed compatibility with scientific-0.3.\*, thanks to Adam Bergmark * Improved documentation of the FromField module, as well as the fold, foldWithOptions, executeMany, and returning operators.
postgresql-simple.cabal view
@@ -1,6 +1,6 @@ Cabal-version: 1.12 Name: postgresql-simple-Version: 0.6+Version: 0.6.1 Synopsis: Mid-Level PostgreSQL client library Description:@@ -11,7 +11,7 @@ Maintainer: Oleg Grenrus <oleg.grenrus@iki.fi> Copyright: (c) 2011 MailRank, Inc. (c) 2011-2018 Leon P Smith- (c) 2018 Oleg Grenrus+ (c) 2018-2019 Oleg Grenrus Category: Database Build-type: Simple @@ -28,7 +28,7 @@ || == 8.0.2 || == 8.2.2 || == 8.4.4- || == 8.6.1+ || == 8.6.3 Library default-language: Haskell2010@@ -121,6 +121,22 @@ location: http://github.com/phadej/postgresql-simple tag: v0.6 +test-suite inspection+ if !impl(ghc >= 8.0)+ buildable: False++ default-language: Haskell2010+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Inspection.hs+ build-depends:+ base+ , inspection-testing >=0.4.1.1 && <0.5+ , postgresql-simple+ , postgresql-libpq+ , tasty+ , tasty-hunit+ test-suite test default-language: Haskell2010 type: exitcode-stdio-1.0@@ -148,7 +164,7 @@ , base16-bytestring , bytestring , containers- , cryptohash+ , cryptohash-md5 >= 0.11.100.1 && <0.12 , filepath , tasty , tasty-hunit
src/Database/PostgreSQL/Simple.hs view
@@ -276,21 +276,31 @@ skipSpace = B.dropWhile isSpace_ascii - buildQuery :: Connection -> Query -> ByteString -> [Action] -> IO Builder buildQuery conn q template xs = zipParams (split template) <$> mapM (buildAction conn q xs) xs where split s =- let (h,t) = B.break (=='?') s+ -- This part escapes double '??'s to make literal '?'s possible+ -- in PostgreSQL queries using the JSON operators: @?@, @?|@ and @?&@+ let (h,t) = breakOnSingleQuestionMark s in byteString h : if B.null t then [] else split (B.tail t) zipParams (t:ts) (p:ps) = t <> p <> zipParams ts ps zipParams [t] [] = t- zipParams _ _ = fmtError (show (B.count '?' template) ++- " '?' characters, but " +++ zipParams _ _ = fmtError (show countSingleQs +++ " single '?' characters, but " ++ show (length xs) ++ " parameters") q xs+ countSingleQs = go 0 template+ where go i "" = (i :: Int)+ go i bs = case qms of+ ("?","?") -> go i nextQMBS+ ("?",_) -> go (i+1) nextQMBS+ _ -> i+ where qms = B.splitAt 1 qmBS+ (qmBS,nextQMBS) = B.splitAt 2 qmBS'+ qmBS' = B.dropWhile (/= '?') bs -- | Execute an @INSERT@, @UPDATE@, or other SQL query that is not -- expected to return results.@@ -521,7 +531,7 @@ -> a -- ^ Initial state for result consumer. -> (a -> r -> IO a) -- ^ Result consumer. -> IO a-foldWithOptions_ opts conn query a f = doFold opts fromRow 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@@ -531,7 +541,7 @@ -> 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+foldWithOptionsAndParser_ opts parser conn query' a f = doFold opts parser conn query' query' a f doFold :: FoldOptions -> RowParser row@@ -567,8 +577,8 @@ go = bracket declare closeCursor $ \cursor -> let loop a = fetch cursor a >>= \r -> case r of- Left a -> return a- Right a -> loop a+ Left x -> return x+ Right x -> loop x in loop a0 -- FIXME: choose the Automatic chunkSize more intelligently
src/Database/PostgreSQL/Simple/Arrays.hs view
@@ -42,9 +42,9 @@ quoted :: Parser ByteString quoted = char '"' *> option "" contents <* char '"' where- esc = char '\\' *> (char '\\' <|> char '"')+ esc' = char '\\' *> (char '\\' <|> char '"') unQ = takeWhile1 (notInClass "\"\\")- contents = mconcat <$> many (unQ <|> B.singleton <$> esc)+ contents = mconcat <$> many (unQ <|> B.singleton <$> esc') -- | Recognizes a plain string literal, not containing quotes or brackets and -- not containing the delimiter character.
src/Database/PostgreSQL/Simple/Copy.hs view
@@ -48,7 +48,7 @@ import qualified Database.PostgreSQL.LibPQ as PQ import Database.PostgreSQL.Simple import Database.PostgreSQL.Simple.Types-import Database.PostgreSQL.Simple.Internal+import Database.PostgreSQL.Simple.Internal hiding (result, row) -- | Issue a @COPY FROM STDIN@ or @COPY TO STDOUT@ query. In the former
src/Database/PostgreSQL/Simple/Cursor.hs view
@@ -30,7 +30,7 @@ import Database.PostgreSQL.Simple.Compat ((<>), toByteString) import Database.PostgreSQL.Simple.FromRow (FromRow(..)) import Database.PostgreSQL.Simple.Types (Query(..))-import Database.PostgreSQL.Simple.Internal as Base+import Database.PostgreSQL.Simple.Internal as Base hiding (result, row) import Database.PostgreSQL.Simple.Internal.PQResultUtils import Database.PostgreSQL.Simple.Transaction import qualified Database.PostgreSQL.LibPQ as PQ@@ -90,9 +90,9 @@ foldM' :: (Ord n, Num n) => (a -> n -> IO a) -> a -> n -> n -> IO a foldM' f a lo hi = loop a lo where- loop a !n- | n > hi = return a+ loop x !n+ | n > hi = return x | otherwise = do- a' <- f a n- loop a' (n+1)+ x' <- f x n+ loop x' (n+1) {-# INLINE foldM' #-}
src/Database/PostgreSQL/Simple/FromField.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor #-} {-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} {-# LANGUAGE PatternGuards, ScopedTypeVariables #-}-{-# LANGUAGE RecordWildCards, TemplateHaskell #-}+{-# LANGUAGE RecordWildCards #-} {- | Module: Database.PostgreSQL.Simple.FromField@@ -117,6 +117,7 @@ import Control.Concurrent.MVar (MVar, newMVar) import Control.Exception (Exception) import qualified Data.Aeson as JSON+import qualified Data.Aeson.Internal as JSON import qualified Data.Aeson.Parser as JSON (value') import Data.Attoparsec.ByteString.Char8 hiding (Result) import Data.ByteString (ByteString)@@ -135,7 +136,6 @@ import Database.PostgreSQL.Simple.Types import Database.PostgreSQL.Simple.TypeInfo as TI import qualified Database.PostgreSQL.Simple.TypeInfo.Static as TI-import Database.PostgreSQL.Simple.TypeInfo.Macro as TI import Database.PostgreSQL.Simple.Time import Database.PostgreSQL.Simple.Arrays as Arrays import qualified Database.PostgreSQL.LibPQ as PQ@@ -262,7 +262,7 @@ -- | void instance FromField () where fromField f _bs- | typeOid f /= $(inlineTypoid TI.void) = returnError Incompatible f ""+ | typeOid f /= TI.voidOid = returnError Incompatible f "" | otherwise = pure () -- | For dealing with null values. Compatible with any postgresql type@@ -292,7 +292,7 @@ -- | bool instance FromField Bool where fromField f bs- | typeOid f /= $(inlineTypoid TI.bool) = returnError Incompatible f ""+ | typeOid f /= TI.boolOid = returnError Incompatible f "" | bs == Nothing = returnError UnexpectedNull f "" | bs == Just "t" = pure True | bs == Just "f" = pure False@@ -300,9 +300,9 @@ -- | \"char\", bpchar instance FromField Char where- fromField f bs =- if $(mkCompats [TI.char,TI.bpchar]) (typeOid f)- then case bs of+ fromField f bs0 =+ if (eq TI.charOid \/ eq TI.bpcharOid) (typeOid f)+ then case bs0 of Nothing -> returnError UnexpectedNull f "" Just bs -> if B.length bs /= 1 then returnError ConversionFailed f "length not 1"@@ -339,23 +339,23 @@ -- better accuracy convert to 'Scientific' or 'Rational' first) instance FromField Float where fromField = atto ok (realToFrac <$> pg_double)- where ok = $(mkCompats [TI.float4,TI.int2])+ where ok = eq TI.float4Oid \/ eq TI.int2Oid -- | int2, int4, float4, float8 (Uses attoparsec's 'double' routine, for -- better accuracy convert to 'Scientific' or 'Rational' first) instance FromField Double where fromField = atto ok pg_double- where ok = $(mkCompats [TI.float4,TI.float8,TI.int2,TI.int4])+ where ok = eq TI.float4Oid \/ eq TI.float8Oid \/ eq TI.int2Oid \/ eq TI.int4Oid -- | 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.int8,TI.numeric])+ where ok = eq TI.float4Oid \/ eq TI.float8Oid \/ eq TI.int2Oid \/ eq TI.int4Oid \/ eq TI.int8Oid \/ eq TI.numericOid -- | 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.int8,TI.numeric])+ where ok = eq TI.float4Oid \/ eq TI.float8Oid \/ eq TI.int2Oid \/ eq TI.int4Oid \/ eq TI.int8Oid \/ eq TI.numericOid unBinary :: Binary t -> t unBinary (Binary x) = x@@ -376,13 +376,13 @@ -- | bytea, name, text, \"char\", bpchar, varchar, unknown instance FromField SB.ByteString where- fromField f dat = if typeOid f == $(inlineTypoid TI.bytea)+ fromField f dat = if typeOid f == TI.byteaOid then unBinary <$> fromField f dat else doFromField f okText' pure dat -- | oid instance FromField PQ.Oid where- fromField f dat = PQ.Oid <$> atto (== $(inlineTypoid TI.oid)) decimal f dat+ fromField f dat = PQ.Oid <$> atto (== TI.oidOid) decimal f dat -- | bytea, name, text, \"char\", bpchar, varchar, unknown instance FromField LB.ByteString where@@ -390,7 +390,7 @@ unescapeBytea :: Field -> SB.ByteString -> Conversion (Binary SB.ByteString)-unescapeBytea f str = case unsafeDupablePerformIO (PQ.unescapeBytea str) of+unescapeBytea f str' = case unsafeDupablePerformIO (PQ.unescapeBytea str') of Nothing -> returnError ConversionFailed f "unescapeBytea failed" Just str -> pure (Binary str) @@ -441,48 +441,48 @@ -- | timestamptz instance FromField UTCTime where- fromField = ff $(inlineTypoid TI.timestamptz) "UTCTime" parseUTCTime+ fromField = ff TI.timestamptzOid "UTCTime" parseUTCTime -- | timestamptz instance FromField ZonedTime where- fromField = ff $(inlineTypoid TI.timestamptz) "ZonedTime" parseZonedTime+ fromField = ff TI.timestamptzOid "ZonedTime" parseZonedTime -- | timestamp instance FromField LocalTime where- fromField = ff $(inlineTypoid TI.timestamp) "LocalTime" parseLocalTime+ fromField = ff TI.timestampOid "LocalTime" parseLocalTime -- | date instance FromField Day where- fromField = ff $(inlineTypoid TI.date) "Day" parseDay+ fromField = ff TI.dateOid "Day" parseDay -- | time instance FromField TimeOfDay where- fromField = ff $(inlineTypoid TI.time) "TimeOfDay" parseTimeOfDay+ fromField = ff TI.timeOid "TimeOfDay" parseTimeOfDay -- | timestamptz instance FromField UTCTimestamp where- fromField = ff $(inlineTypoid TI.timestamptz) "UTCTimestamp" parseUTCTimestamp+ fromField = ff TI.timestamptzOid "UTCTimestamp" parseUTCTimestamp -- | timestamptz instance FromField ZonedTimestamp where- fromField = ff $(inlineTypoid TI.timestamptz) "ZonedTimestamp" parseZonedTimestamp+ fromField = ff TI.timestamptzOid "ZonedTimestamp" parseZonedTimestamp -- | timestamp instance FromField LocalTimestamp where- fromField = ff $(inlineTypoid TI.timestamp) "LocalTimestamp" parseLocalTimestamp+ fromField = ff TI.timestampOid "LocalTimestamp" parseLocalTimestamp -- | date instance FromField Date where- fromField = ff $(inlineTypoid TI.date) "Date" parseDate+ fromField = ff TI.dateOid "Date" parseDate ff :: PQ.Oid -> String -> (B8.ByteString -> Either String a) -> Field -> Maybe B8.ByteString -> Conversion a-ff compatOid hsType parse f mstr =+ff compatOid hsType parseBS f mstr = if typeOid f /= compatOid then err Incompatible "" else case mstr of Nothing -> err UnexpectedNull ""- Just str -> case parse str of+ Just str -> case parseBS str of Left msg -> err ConversionFailed msg Right val -> return val where@@ -520,10 +520,10 @@ _ -> returnError Incompatible f "" fromArray :: FieldParser a -> TypeInfo -> Field -> Parser (Conversion [a])-fromArray fieldParser typeInfo f = sequence . (parseIt <$>) <$> array delim+fromArray fieldParser typInfo f = sequence . (parseIt <$>) <$> array delim where- delim = typdelim (typelem typeInfo)- fElem = f{ typeOid = typoid (typelem typeInfo) }+ delim = typdelim (typelem typInfo)+ fElem = f{ typeOid = typoid (typelem typInfo) } parseIt item = fieldParser f' $ if item == Arrays.Plain "NULL" then Nothing else Just item'@@ -541,7 +541,7 @@ -- | uuid instance FromField UUID where fromField f mbs =- if typeOid f /= $(inlineTypoid TI.uuid)+ if typeOid f /= TI.uuidOid then returnError Incompatible f "" else case mbs of Nothing -> returnError UnexpectedNull f ""@@ -552,22 +552,22 @@ -- | json, jsonb instance FromField JSON.Value where- fromField f mbs = parse =<< fromFieldJSONByteString f mbs- where parse bs = case parseOnly (JSON.value' <* endOfInput) bs of+ fromField f mbs = parseBS =<< fromFieldJSONByteString f mbs+ where parseBS bs = case parseOnly (JSON.value' <* endOfInput) bs of Left err -> returnError ConversionFailed f err Right val -> pure val -- | Return the JSON ByteString directly fromFieldJSONByteString :: Field -> Maybe ByteString -> Conversion ByteString fromFieldJSONByteString f mbs =- if typeOid f /= $(inlineTypoid TI.json) && typeOid f /= $(inlineTypoid TI.jsonb)+ if typeOid f /= TI.jsonOid && typeOid f /= TI.jsonbOid then returnError Incompatible f "" else case mbs of Nothing -> returnError UnexpectedNull f "" Just bs -> pure bs -- | Parse a field to a JSON 'JSON.Value' and convert that into a--- Haskell value using 'JSON.fromJSON'.+-- Haskell value using the 'JSON.FromJSON' instance. -- -- This can be used as the default implementation for the 'fromField' -- method for Haskell types that have a JSON representation in@@ -588,10 +588,10 @@ fromJSONField :: (JSON.FromJSON a, Typeable a) => FieldParser a fromJSONField f mbBs = do value <- fromField f mbBs- case JSON.fromJSON value of- JSON.Error err -> returnError ConversionFailed f $- "JSON decoding error: " ++ err- JSON.Success x -> pure x+ case JSON.ifromJSON value of+ JSON.IError path err -> returnError ConversionFailed f $+ "JSON decoding error: " ++ (JSON.formatError path err)+ JSON.ISuccess x -> pure x -- | Compatible with the same set of types as @a@. Note that -- modifying the 'IORef' does not have any effects outside@@ -608,19 +608,32 @@ type Compat = PQ.Oid -> Bool okText, okText', okBinary, ok16, ok32, ok64, okInt :: Compat-okText = $( mkCompats [ TI.name, TI.text, TI.char,- TI.bpchar, TI.varchar ] )-okText' = $( mkCompats [ TI.name, TI.text, TI.char,- TI.bpchar, TI.varchar, TI.unknown ] )-okBinary = (== $( inlineTypoid TI.bytea ))-ok16 = (== $( inlineTypoid TI.int2 ))-ok32 = $( mkCompats [TI.int2,TI.int4] )-ok64 = $( mkCompats [TI.int2,TI.int4,TI.int8] )+okText = eq TI.nameOid \/ eq TI.textOid \/ eq TI.charOid+ \/ eq TI.bpcharOid \/ eq TI.varcharOid+okText' = eq TI.nameOid \/ eq TI.textOid \/ eq TI.charOid+ \/ eq TI.bpcharOid \/ eq TI.varcharOid \/ eq TI.unknownOid+okBinary = eq TI.byteaOid+ok16 = eq TI.int2Oid+ok32 = eq TI.int2Oid \/ eq TI.int4Oid+ok64 = eq TI.int2Oid \/ eq TI.int4Oid \/ eq TI.int8Oid #if WORD_SIZE_IN_BITS < 64 okInt = ok32 #else okInt = ok64 #endif++-- | eq and \/ are used to imlement what Macro stuff did,+-- i.e. mkCompats and inlineTypoid+eq :: PQ.Oid -> PQ.Oid -> Bool+eq = (==)+{-# INLINE eq #-}++infixr 2 \/+(\/) :: (PQ.Oid -> Bool)+ -> (PQ.Oid -> Bool)+ -> (PQ.Oid -> Bool)+f \/ g = \x -> f x || g x+{-# INLINE (\/) #-} doFromField :: forall a . (Typeable a) => Field -> Compat -> (ByteString -> Conversion a)
src/Database/PostgreSQL/Simple/FromRow.hs view
@@ -67,6 +67,23 @@ -- in a single row of the query result. Otherwise, a 'ConversionFailed' -- exception will be thrown. --+-- You can also derive 'FromRow' for your data type using GHC generics, like+-- this:+--+-- @+-- \{-# LANGUAGE DeriveAnyClass \#-}+-- \{-# LANGUAGE DeriveGeneric \#-}+--+-- import "GHC.Generics" ('GHC.Generics.Generic')+-- import "Database.PostgreSQL.Simple" ('FromRow')+--+-- data User = User { name :: String, fileQuota :: Int }+-- deriving ('GHC.Generics.Generic', 'FromRow')+-- @+--+-- Note that this only works for product types (e.g. records) and does not+-- support sum types or recursive types.+-- -- Note that 'field' evaluates its result to WHNF, so the caveats listed in -- mysql-simple and very early versions of postgresql-simple no longer apply. -- Instead, look at the caveats associated with user-defined implementations@@ -114,8 +131,8 @@ else do let !result = rowresult !typeOid = unsafeDupablePerformIO (PQ.ftype result column)- !field = Field{..}- lift (lift (fieldP field (getvalue result row column)))+ !field' = Field{..}+ lift (lift (fieldP field' (getvalue result row column))) field :: FromField a => RowParser a field = fieldWith fromField
src/Database/PostgreSQL/Simple/HStore/Implementation.hs view
@@ -53,12 +53,12 @@ toBuilder :: HStoreBuilder -> Builder toBuilder x = case x of Empty -> mempty- Comma x -> x+ Comma c -> c toLazyByteString :: HStoreBuilder -> BL.ByteString toLazyByteString x = case x of Empty -> BL.empty- Comma x -> BU.toLazyByteString x+ Comma c -> BU.toLazyByteString c instance Semigroup HStoreBuilder where Empty <> x = x@@ -150,7 +150,7 @@ instance ToHStore HStoreMap where toHStore (HStoreMap xs) = Map.foldrWithKey f mempty xs- where f k v xs = hstore k v `mappend` xs+ where f k v xs' = hstore k v `mappend` xs' instance ToField HStoreMap where toField xs = toField (toHStore xs)
src/Database/PostgreSQL/Simple/Internal.hs view
@@ -290,7 +290,7 @@ str name field | null value = id- | otherwise = showString name . quote value . space+ | otherwise = showString name . addQuotes value . space where value = field connectInfo num name field@@ -298,7 +298,7 @@ | otherwise = showString name . shows value . space where value = field connectInfo - quote str rest = '\'' : foldr delta ('\'' : rest) str+ addQuotes s rest = '\'' : foldr delta ('\'' : rest) s where delta c cs = case c of '\\' -> '\\' : '\\' : cs@@ -386,7 +386,7 @@ nstr <- PQ.cmdTuples result return $ case nstr of Nothing -> 0 -- is this appropriate?- Just str -> toInteger str+ Just str -> mkInteger str PQ.TuplesOk -> do ncols <- PQ.nfields result throwIO $ QueryError ("execute resulted in " ++ show ncols ++@@ -399,7 +399,7 @@ PQ.NonfatalError -> throwResultError "execute" result status PQ.FatalError -> throwResultError "execute" result status where- toInteger str = B8.foldl' delta 0 str+ mkInteger str = B8.foldl' delta 0 str where delta acc c = if '0' <= c && c <= '9'@@ -414,8 +414,8 @@ PQ.resultErrorField result PQ.DiagMessageDetail hint <- fromMaybe "" <$> PQ.resultErrorField result PQ.DiagMessageHint- state <- maybe "" id <$> PQ.resultErrorField result PQ.DiagSqlstate- throwIO $ SqlError { sqlState = state+ state' <- maybe "" id <$> PQ.resultErrorField result PQ.DiagSqlstate+ throwIO $ SqlError { sqlState = state' , sqlExecStatus = status , sqlErrorMsg = errormsg , sqlErrorDetail = detail@@ -589,3 +589,19 @@ escapeByteaConn :: Connection -> ByteString -> IO (Either ByteString ByteString) escapeByteaConn = escapeWrap PQ.escapeByteaConn++breakOnSingleQuestionMark :: ByteString -> (ByteString, ByteString)+breakOnSingleQuestionMark b = go (B8.empty, b)+ where go (x,bs) = (x `B8.append` x',bs')+ -- seperate from first QM+ where tup@(noQ, restWithQ) = B8.break (=='?') bs+ -- if end of query, just return+ -- else check for second QM in 'go2'+ (x', bs') = maybe tup go2 $+ -- drop found QM and peek at next char+ B8.uncons restWithQ >>= B8.uncons . snd+ -- another QM after the first means:+ -- take literal QM and keep going.+ go2 ('?', t2) = go (noQ `B8.snoc` '?',t2)+ -- Anything else means+ go2 _ = tup
src/Database/PostgreSQL/Simple/Internal/PQResultUtils.hs view
@@ -25,7 +25,7 @@ import Database.PostgreSQL.Simple.FromField (ResultError(..)) import Database.PostgreSQL.Simple.Ok import Database.PostgreSQL.Simple.Types (Query(..))-import Database.PostgreSQL.Simple.Internal as Base+import Database.PostgreSQL.Simple.Internal as Base hiding (result, row) import Database.PostgreSQL.Simple.TypeInfo import qualified Database.PostgreSQL.LibPQ as PQ import qualified Data.ByteString.Char8 as B@@ -73,7 +73,7 @@ case status of PQ.TuplesOk -> k PQ.EmptyQuery -> queryErr "query: Empty query"- PQ.CommandOk -> queryErr "query resulted in a command response"+ PQ.CommandOk -> queryErr "query resulted in a command response (did you mean to use `execute` or forget a RETURNING?)" PQ.CopyOut -> queryErr "query: COPY TO is not supported" PQ.CopyIn -> queryErr "query: COPY FROM is not supported" #if MIN_VERSION_postgresql_libpq(0,9,3)
src/Database/PostgreSQL/Simple/Range.hs view
@@ -110,19 +110,19 @@ PGRange _lb NegInfinity -> False PGRange lb ub -> checkLB lb x && checkUB ub x where- checkLB lb x =+ checkLB lb y = case lb of NegInfinity -> True PosInfinity -> False- Inclusive a -> cmp a x /= GT- Exclusive a -> cmp a x == LT+ Inclusive a -> cmp a y /= GT+ Exclusive a -> cmp a y == LT - checkUB ub x =+ checkUB ub y = case ub of NegInfinity -> False PosInfinity -> True- Inclusive z -> cmp x z /= GT- Exclusive z -> cmp x z == LT+ Inclusive z -> cmp y z /= GT+ Exclusive z -> cmp y z == LT lowerBound :: Parser (a -> RangeBound a) lowerBound = (A.char '(' *> pure Exclusive) <|> (A.char '[' *> pure Inclusive)
src/Database/PostgreSQL/Simple/SqlQQ.hs view
@@ -1,4 +1,9 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 800+{-# LANGUAGE TemplateHaskellQuotes #-}+#else {-# LANGUAGE TemplateHaskell #-}+#endif ------------------------------------------------------------------------------ -- | -- Module: Database.PostgreSQL.Simple.SqlQQ@@ -52,13 +57,10 @@ sql :: QuasiQuoter sql = QuasiQuoter- { quotePat = error "Database.PostgreSQL.Simple.SqlQQ.sql:\- \ quasiquoter used in pattern context"- , quoteType = error "Database.PostgreSQL.Simple.SqlQQ.sql:\- \ quasiquoter used in type context"+ { quotePat = error "Database.PostgreSQL.Simple.SqlQQ.sql: quasiquoter used in pattern context"+ , quoteType = error "Database.PostgreSQL.Simple.SqlQQ.sql: quasiquoter used in type context" , quoteExp = sqlExp- , quoteDec = error "Database.PostgreSQL.Simple.SqlQQ.sql:\- \ quasiquoter used in declaration context"+ , quoteDec = error "Database.PostgreSQL.Simple.SqlQQ.sql: quasiquoter used in declaration context" } sqlExp :: String -> Q Exp@@ -85,5 +87,4 @@ instring ('\'':'\'':xs) = '\'':'\'': instring xs instring ('\'':xs) = '\'': insql xs instring (x:xs) = x : instring xs- instring [] = error "Database.PostgreSQL.Simple.SqlQQ.sql:\- \ string literal not terminated"+ instring [] = error "Database.PostgreSQL.Simple.SqlQQ.sql: string literal not terminated"
src/Database/PostgreSQL/Simple/ToField.hs view
@@ -319,7 +319,7 @@ 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+interleaveFoldr f b bs' as = foldr (\a bs -> b : f a bs) bs' as {-# INLINE interleaveFoldr #-} instance ToRow a => ToField (Values a) where@@ -366,8 +366,8 @@ typedRows :: ToRow a => [a] -> [QualifiedIdentifier] -> [Action] -> [Action] typedRows [] _ _ = error funcname- typedRows (val:vals) types rest =- typedRow (toRow val) types (multiRows vals rest)+ typedRows (val:vals) typs rest =+ typedRow (toRow val) typs (multiRows vals rest) untypedRows :: ToRow a => [a] -> [Action] -> [Action] untypedRows [] _ = error funcname
src/Database/PostgreSQL/Simple/ToRow.hs view
@@ -30,6 +30,22 @@ -- -- Instances should use the 'toField' method of the 'ToField' class -- to perform conversion of each element of the collection.+--+-- You can derive 'ToRow' for your data type using GHC generics, like this:+--+-- @+-- \{-# LANGUAGE DeriveAnyClass \#-}+-- \{-# LANGUAGE DeriveGeneric \#-}+--+-- import "GHC.Generics" ('GHC.Generics.Generic')+-- import "Database.PostgreSQL.Simple" ('ToRow')+--+-- data User = User { name :: String, fileQuota :: Int }+-- deriving ('GHC.Generics.Generic', 'ToRow')+-- @+--+-- Note that this only works for product types (e.g. records) and does not+-- support sum types or recursive types. class ToRow a where toRow :: a -> [Action] default toRow :: (Generic a, GToRow (Rep a)) => a -> [Action]
src/Database/PostgreSQL/Simple/TypeInfo.hs view
@@ -50,21 +50,21 @@ -- in the connections's cache. getTypeInfo :: Connection -> PQ.Oid -> IO TypeInfo-getTypeInfo conn@Connection{..} oid =- case staticTypeInfo oid of- Just name -> return name- Nothing -> modifyMVar connectionObjects $ getTypeInfo' conn oid+getTypeInfo conn@Connection{..} oid' =+ case staticTypeInfo oid' of+ Just name' -> return name'+ Nothing -> modifyMVar connectionObjects $ getTypeInfo' conn oid' getTypeInfo' :: Connection -> PQ.Oid -> TypeInfoCache -> IO (TypeInfoCache, TypeInfo)-getTypeInfo' conn oid oidmap =- case IntMap.lookup (oid2int oid) oidmap of+getTypeInfo' conn oid' oidmap =+ case IntMap.lookup (oid2int oid') oidmap of Just typeinfo -> return (oidmap, typeinfo) Nothing -> do names <- query conn "SELECT oid, typcategory, typdelim, typname,\ \ typelem, typrelid\ \ FROM pg_type WHERE oid = ?"- (Only oid)+ (Only oid') (oidmap', typeInfo) <- case names of [] -> return $ throw (fatalError "invalid type oid")@@ -78,7 +78,7 @@ rngsubtypeOids <- query conn "SELECT rngsubtype\ \ FROM pg_range\ \ WHERE rngtypid = ?"- (Only oid)+ (Only oid') case rngsubtypeOids of [Only rngsubtype_] -> do (oidmap', rngsubtype) <-@@ -104,7 +104,7 @@ _ -> fail "typename query returned more than one result" -- oid is a primary key, so the query should -- never return more than one result- let !oidmap'' = IntMap.insert (oid2int oid) typeInfo oidmap'+ let !oidmap'' = IntMap.insert (oid2int oid') typeInfo oidmap' return $! (oidmap'', typeInfo) getAttInfos :: Connection -> [(B.ByteString, PQ.Oid)] -> TypeInfoCache
src/Database/PostgreSQL/Simple/TypeInfo/Macro.hs view
@@ -1,4 +1,9 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 800+{-# LANGUAGE TemplateHaskellQuotes #-}+#else {-# LANGUAGE TemplateHaskell #-}+#endif ------------------------------------------------------------------------------ -- |@@ -22,11 +27,12 @@ import Database.PostgreSQL.Simple.Types (Oid(..)) import Language.Haskell.TH - -- | Returns an expression that has type @'Oid' -> 'Bool'@, true if the -- oid is equal to any one of the 'typoid's of the given 'TypeInfo's. mkCompats :: [TypeInfo] -> ExpQ-mkCompats tys = [| \(Oid x) -> $(caseE [| x |] (map alt tys ++ [catchAll])) |]+mkCompats tys = do+ x <- newName "x"+ lamE [conP 'Oid [varP x]] $ caseE (varE x) (map alt tys ++ [catchAll]) where alt :: TypeInfo -> MatchQ alt ty = match (inlineTypoidP ty) (normalB [| True |]) []@@ -38,7 +44,7 @@ -- Returns an expression of type 'Oid'. Useful because GHC tends -- not to fold constants. inlineTypoid :: TypeInfo -> ExpQ-inlineTypoid ty = [| Oid $(litE (getTypoid ty)) |]+inlineTypoid ty = conE 'Oid `appE` litE (getTypoid ty) inlineTypoidP :: TypeInfo -> PatQ inlineTypoidP ty = litP (getTypoid ty)
src/Database/PostgreSQL/Simple/TypeInfo/Static.hs view
@@ -19,119 +19,233 @@ ( TypeInfo(..) , staticTypeInfo , bool+ , boolOid , bytea+ , byteaOid , char+ , charOid , name+ , nameOid , int8+ , int8Oid , int2+ , int2Oid , int4+ , int4Oid , regproc+ , regprocOid , text+ , textOid , oid+ , oidOid , tid+ , tidOid , xid+ , xidOid , cid+ , cidOid , xml+ , xmlOid , point+ , pointOid , lseg+ , lsegOid , path+ , pathOid , box+ , boxOid , polygon+ , polygonOid , line+ , lineOid , cidr+ , cidrOid , float4+ , float4Oid , float8+ , float8Oid , unknown+ , unknownOid , circle+ , circleOid , money+ , moneyOid , macaddr+ , macaddrOid , inet+ , inetOid , bpchar+ , bpcharOid , varchar+ , varcharOid , date+ , dateOid , time+ , timeOid , timestamp+ , timestampOid , timestamptz+ , timestamptzOid , interval+ , intervalOid , timetz+ , timetzOid , bit+ , bitOid , varbit+ , varbitOid , numeric+ , numericOid , refcursor+ , refcursorOid , record+ , recordOid , void+ , voidOid , array_record+ , array_recordOid , regprocedure+ , regprocedureOid , regoper+ , regoperOid , regoperator+ , regoperatorOid , regclass+ , regclassOid , regtype+ , regtypeOid , uuid+ , uuidOid , json+ , jsonOid , jsonb+ , jsonbOid , int2vector+ , int2vectorOid , oidvector+ , oidvectorOid , array_xml+ , array_xmlOid , array_json+ , array_jsonOid , array_line+ , array_lineOid , array_cidr+ , array_cidrOid , array_circle+ , array_circleOid , array_money+ , array_moneyOid , array_bool+ , array_boolOid , array_bytea+ , array_byteaOid , array_char+ , array_charOid , array_name+ , array_nameOid , array_int2+ , array_int2Oid , array_int2vector+ , array_int2vectorOid , array_int4+ , array_int4Oid , array_regproc+ , array_regprocOid , array_text+ , array_textOid , array_tid+ , array_tidOid , array_xid+ , array_xidOid , array_cid+ , array_cidOid , array_oidvector+ , array_oidvectorOid , array_bpchar+ , array_bpcharOid , array_varchar+ , array_varcharOid , array_int8+ , array_int8Oid , array_point+ , array_pointOid , array_lseg+ , array_lsegOid , array_path+ , array_pathOid , array_box+ , array_boxOid , array_float4+ , array_float4Oid , array_float8+ , array_float8Oid , array_polygon+ , array_polygonOid , array_oid+ , array_oidOid , array_macaddr+ , array_macaddrOid , array_inet+ , array_inetOid , array_timestamp+ , array_timestampOid , array_date+ , array_dateOid , array_time+ , array_timeOid , array_timestamptz+ , array_timestamptzOid , array_interval+ , array_intervalOid , array_numeric+ , array_numericOid , array_timetz+ , array_timetzOid , array_bit+ , array_bitOid , array_varbit+ , array_varbitOid , array_refcursor+ , array_refcursorOid , array_regprocedure+ , array_regprocedureOid , array_regoper+ , array_regoperOid , array_regoperator+ , array_regoperatorOid , array_regclass+ , array_regclassOid , array_regtype+ , array_regtypeOid , array_uuid+ , array_uuidOid , array_jsonb+ , array_jsonbOid , int4range+ , int4rangeOid , _int4range+ , _int4rangeOid , numrange+ , numrangeOid , _numrange+ , _numrangeOid , tsrange+ , tsrangeOid , _tsrange+ , _tsrangeOid , tstzrange+ , tstzrangeOid , _tstzrange+ , _tstzrangeOid , daterange+ , daterangeOid , _daterange+ , _daterangeOid , int8range+ , int8rangeOid , _int8range+ , _int8rangeOid ) where import Database.PostgreSQL.LibPQ (Oid(..))@@ -257,976 +371,1432 @@ bool :: TypeInfo bool = Basic {- typoid = Oid 16,+ typoid = boolOid, typcategory = 'B', typdelim = ',', typname = "bool" } +boolOid :: Oid+boolOid = Oid 16+{-# INLINE boolOid #-}+ bytea :: TypeInfo bytea = Basic {- typoid = Oid 17,+ typoid = byteaOid, typcategory = 'U', typdelim = ',', typname = "bytea" } +byteaOid :: Oid+byteaOid = Oid 17+{-# INLINE byteaOid #-}+ char :: TypeInfo char = Basic {- typoid = Oid 18,+ typoid = charOid, typcategory = 'S', typdelim = ',', typname = "char" } +charOid :: Oid+charOid = Oid 18+{-# INLINE charOid #-}+ name :: TypeInfo name = Basic {- typoid = Oid 19,+ typoid = nameOid, typcategory = 'S', typdelim = ',', typname = "name" } +nameOid :: Oid+nameOid = Oid 19+{-# INLINE nameOid #-}+ int8 :: TypeInfo int8 = Basic {- typoid = Oid 20,+ typoid = int8Oid, typcategory = 'N', typdelim = ',', typname = "int8" } +int8Oid :: Oid+int8Oid = Oid 20+{-# INLINE int8Oid #-}+ int2 :: TypeInfo int2 = Basic {- typoid = Oid 21,+ typoid = int2Oid, typcategory = 'N', typdelim = ',', typname = "int2" } +int2Oid :: Oid+int2Oid = Oid 21+{-# INLINE int2Oid #-}+ int4 :: TypeInfo int4 = Basic {- typoid = Oid 23,+ typoid = int4Oid, typcategory = 'N', typdelim = ',', typname = "int4" } +int4Oid :: Oid+int4Oid = Oid 23+{-# INLINE int4Oid #-}+ regproc :: TypeInfo regproc = Basic {- typoid = Oid 24,+ typoid = regprocOid, typcategory = 'N', typdelim = ',', typname = "regproc" } +regprocOid :: Oid+regprocOid = Oid 24+{-# INLINE regprocOid #-}+ text :: TypeInfo text = Basic {- typoid = Oid 25,+ typoid = textOid, typcategory = 'S', typdelim = ',', typname = "text" } +textOid :: Oid+textOid = Oid 25+{-# INLINE textOid #-}+ oid :: TypeInfo oid = Basic {- typoid = Oid 26,+ typoid = oidOid, typcategory = 'N', typdelim = ',', typname = "oid" } +oidOid :: Oid+oidOid = Oid 26+{-# INLINE oidOid #-}+ tid :: TypeInfo tid = Basic {- typoid = Oid 27,+ typoid = tidOid, typcategory = 'U', typdelim = ',', typname = "tid" } +tidOid :: Oid+tidOid = Oid 27+{-# INLINE tidOid #-}+ xid :: TypeInfo xid = Basic {- typoid = Oid 28,+ typoid = xidOid, typcategory = 'U', typdelim = ',', typname = "xid" } +xidOid :: Oid+xidOid = Oid 28+{-# INLINE xidOid #-}+ cid :: TypeInfo cid = Basic {- typoid = Oid 29,+ typoid = cidOid, typcategory = 'U', typdelim = ',', typname = "cid" } +cidOid :: Oid+cidOid = Oid 29+{-# INLINE cidOid #-}+ xml :: TypeInfo xml = Basic {- typoid = Oid 142,+ typoid = xmlOid, typcategory = 'U', typdelim = ',', typname = "xml" } +xmlOid :: Oid+xmlOid = Oid 142+{-# INLINE xmlOid #-}+ point :: TypeInfo point = Basic {- typoid = Oid 600,+ typoid = pointOid, typcategory = 'G', typdelim = ',', typname = "point" } +pointOid :: Oid+pointOid = Oid 600+{-# INLINE pointOid #-}+ lseg :: TypeInfo lseg = Basic {- typoid = Oid 601,+ typoid = lsegOid, typcategory = 'G', typdelim = ',', typname = "lseg" } +lsegOid :: Oid+lsegOid = Oid 601+{-# INLINE lsegOid #-}+ path :: TypeInfo path = Basic {- typoid = Oid 602,+ typoid = pathOid, typcategory = 'G', typdelim = ',', typname = "path" } +pathOid :: Oid+pathOid = Oid 602+{-# INLINE pathOid #-}+ box :: TypeInfo box = Basic {- typoid = Oid 603,+ typoid = boxOid, typcategory = 'G', typdelim = ';', typname = "box" } +boxOid :: Oid+boxOid = Oid 603+{-# INLINE boxOid #-}+ polygon :: TypeInfo polygon = Basic {- typoid = Oid 604,+ typoid = polygonOid, typcategory = 'G', typdelim = ',', typname = "polygon" } +polygonOid :: Oid+polygonOid = Oid 604+{-# INLINE polygonOid #-}+ line :: TypeInfo line = Basic {- typoid = Oid 628,+ typoid = lineOid, typcategory = 'G', typdelim = ',', typname = "line" } +lineOid :: Oid+lineOid = Oid 628+{-# INLINE lineOid #-}+ cidr :: TypeInfo cidr = Basic {- typoid = Oid 650,+ typoid = cidrOid, typcategory = 'I', typdelim = ',', typname = "cidr" } +cidrOid :: Oid+cidrOid = Oid 650+{-# INLINE cidrOid #-}+ float4 :: TypeInfo float4 = Basic {- typoid = Oid 700,+ typoid = float4Oid, typcategory = 'N', typdelim = ',', typname = "float4" } +float4Oid :: Oid+float4Oid = Oid 700+{-# INLINE float4Oid #-}+ float8 :: TypeInfo float8 = Basic {- typoid = Oid 701,+ typoid = float8Oid, typcategory = 'N', typdelim = ',', typname = "float8" } +float8Oid :: Oid+float8Oid = Oid 701+{-# INLINE float8Oid #-}+ unknown :: TypeInfo unknown = Basic {- typoid = Oid 705,+ typoid = unknownOid, typcategory = 'X', typdelim = ',', typname = "unknown" } +unknownOid :: Oid+unknownOid = Oid 705+{-# INLINE unknownOid #-}+ circle :: TypeInfo circle = Basic {- typoid = Oid 718,+ typoid = circleOid, typcategory = 'G', typdelim = ',', typname = "circle" } +circleOid :: Oid+circleOid = Oid 718+{-# INLINE circleOid #-}+ money :: TypeInfo money = Basic {- typoid = Oid 790,+ typoid = moneyOid, typcategory = 'N', typdelim = ',', typname = "money" } +moneyOid :: Oid+moneyOid = Oid 790+{-# INLINE moneyOid #-}+ macaddr :: TypeInfo macaddr = Basic {- typoid = Oid 829,+ typoid = macaddrOid, typcategory = 'U', typdelim = ',', typname = "macaddr" } +macaddrOid :: Oid+macaddrOid = Oid 829+{-# INLINE macaddrOid #-}+ inet :: TypeInfo inet = Basic {- typoid = Oid 869,+ typoid = inetOid, typcategory = 'I', typdelim = ',', typname = "inet" } +inetOid :: Oid+inetOid = Oid 869+{-# INLINE inetOid #-}+ bpchar :: TypeInfo bpchar = Basic {- typoid = Oid 1042,+ typoid = bpcharOid, typcategory = 'S', typdelim = ',', typname = "bpchar" } +bpcharOid :: Oid+bpcharOid = Oid 1042+{-# INLINE bpcharOid #-}+ varchar :: TypeInfo varchar = Basic {- typoid = Oid 1043,+ typoid = varcharOid, typcategory = 'S', typdelim = ',', typname = "varchar" } +varcharOid :: Oid+varcharOid = Oid 1043+{-# INLINE varcharOid #-}+ date :: TypeInfo date = Basic {- typoid = Oid 1082,+ typoid = dateOid, typcategory = 'D', typdelim = ',', typname = "date" } +dateOid :: Oid+dateOid = Oid 1082+{-# INLINE dateOid #-}+ time :: TypeInfo time = Basic {- typoid = Oid 1083,+ typoid = timeOid, typcategory = 'D', typdelim = ',', typname = "time" } +timeOid :: Oid+timeOid = Oid 1083+{-# INLINE timeOid #-}+ timestamp :: TypeInfo timestamp = Basic {- typoid = Oid 1114,+ typoid = timestampOid, typcategory = 'D', typdelim = ',', typname = "timestamp" } +timestampOid :: Oid+timestampOid = Oid 1114+{-# INLINE timestampOid #-}+ timestamptz :: TypeInfo timestamptz = Basic {- typoid = Oid 1184,+ typoid = timestamptzOid, typcategory = 'D', typdelim = ',', typname = "timestamptz" } +timestamptzOid :: Oid+timestamptzOid = Oid 1184+{-# INLINE timestamptzOid #-}+ interval :: TypeInfo interval = Basic {- typoid = Oid 1186,+ typoid = intervalOid, typcategory = 'T', typdelim = ',', typname = "interval" } +intervalOid :: Oid+intervalOid = Oid 1186+{-# INLINE intervalOid #-}+ timetz :: TypeInfo timetz = Basic {- typoid = Oid 1266,+ typoid = timetzOid, typcategory = 'D', typdelim = ',', typname = "timetz" } +timetzOid :: Oid+timetzOid = Oid 1266+{-# INLINE timetzOid #-}+ bit :: TypeInfo bit = Basic {- typoid = Oid 1560,+ typoid = bitOid, typcategory = 'V', typdelim = ',', typname = "bit" } +bitOid :: Oid+bitOid = Oid 1560+{-# INLINE bitOid #-}+ varbit :: TypeInfo varbit = Basic {- typoid = Oid 1562,+ typoid = varbitOid, typcategory = 'V', typdelim = ',', typname = "varbit" } +varbitOid :: Oid+varbitOid = Oid 1562+{-# INLINE varbitOid #-}+ numeric :: TypeInfo numeric = Basic {- typoid = Oid 1700,+ typoid = numericOid, typcategory = 'N', typdelim = ',', typname = "numeric" } +numericOid :: Oid+numericOid = Oid 1700+{-# INLINE numericOid #-}+ refcursor :: TypeInfo refcursor = Basic {- typoid = Oid 1790,+ typoid = refcursorOid, typcategory = 'U', typdelim = ',', typname = "refcursor" } +refcursorOid :: Oid+refcursorOid = Oid 1790+{-# INLINE refcursorOid #-}+ record :: TypeInfo record = Basic {- typoid = Oid 2249,+ typoid = recordOid, typcategory = 'P', typdelim = ',', typname = "record" } +recordOid :: Oid+recordOid = Oid 2249+{-# INLINE recordOid #-}+ void :: TypeInfo void = Basic {- typoid = Oid 2278,+ typoid = voidOid, typcategory = 'P', typdelim = ',', typname = "void" } +voidOid :: Oid+voidOid = Oid 2278+{-# INLINE voidOid #-}+ array_record :: TypeInfo array_record = Array {- typoid = Oid 2287,+ typoid = array_recordOid, typcategory = 'P', typdelim = ',', typname = "_record", typelem = record } +array_recordOid :: Oid+array_recordOid = Oid 2287+{-# INLINE array_recordOid #-}+ regprocedure :: TypeInfo regprocedure = Basic {- typoid = Oid 2202,+ typoid = regprocedureOid, typcategory = 'N', typdelim = ',', typname = "regprocedure" } +regprocedureOid :: Oid+regprocedureOid = Oid 2202+{-# INLINE regprocedureOid #-}+ regoper :: TypeInfo regoper = Basic {- typoid = Oid 2203,+ typoid = regoperOid, typcategory = 'N', typdelim = ',', typname = "regoper" } +regoperOid :: Oid+regoperOid = Oid 2203+{-# INLINE regoperOid #-}+ regoperator :: TypeInfo regoperator = Basic {- typoid = Oid 2204,+ typoid = regoperatorOid, typcategory = 'N', typdelim = ',', typname = "regoperator" } +regoperatorOid :: Oid+regoperatorOid = Oid 2204+{-# INLINE regoperatorOid #-}+ regclass :: TypeInfo regclass = Basic {- typoid = Oid 2205,+ typoid = regclassOid, typcategory = 'N', typdelim = ',', typname = "regclass" } +regclassOid :: Oid+regclassOid = Oid 2205+{-# INLINE regclassOid #-}+ regtype :: TypeInfo regtype = Basic {- typoid = Oid 2206,+ typoid = regtypeOid, typcategory = 'N', typdelim = ',', typname = "regtype" } +regtypeOid :: Oid+regtypeOid = Oid 2206+{-# INLINE regtypeOid #-}+ uuid :: TypeInfo uuid = Basic {- typoid = Oid 2950,+ typoid = uuidOid, typcategory = 'U', typdelim = ',', typname = "uuid" } +uuidOid :: Oid+uuidOid = Oid 2950+{-# INLINE uuidOid #-}+ json :: TypeInfo json = Basic {- typoid = Oid 114,+ typoid = jsonOid, typcategory = 'U', typdelim = ',', typname = "json" } +jsonOid :: Oid+jsonOid = Oid 114+{-# INLINE jsonOid #-}+ jsonb :: TypeInfo jsonb = Basic {- typoid = Oid 3802,+ typoid = jsonbOid, typcategory = 'U', typdelim = ',', typname = "jsonb" } +jsonbOid :: Oid+jsonbOid = Oid 3802+{-# INLINE jsonbOid #-}+ int2vector :: TypeInfo int2vector = Array {- typoid = Oid 22,+ typoid = int2vectorOid, typcategory = 'A', typdelim = ',', typname = "int2vector", typelem = int2 } +int2vectorOid :: Oid+int2vectorOid = Oid 22+{-# INLINE int2vectorOid #-}+ oidvector :: TypeInfo oidvector = Array {- typoid = Oid 30,+ typoid = oidvectorOid, typcategory = 'A', typdelim = ',', typname = "oidvector", typelem = oid } +oidvectorOid :: Oid+oidvectorOid = Oid 30+{-# INLINE oidvectorOid #-}+ array_xml :: TypeInfo array_xml = Array {- typoid = Oid 143,+ typoid = array_xmlOid, typcategory = 'A', typdelim = ',', typname = "_xml", typelem = xml } +array_xmlOid :: Oid+array_xmlOid = Oid 143+{-# INLINE array_xmlOid #-}+ array_json :: TypeInfo array_json = Array {- typoid = Oid 199,+ typoid = array_jsonOid, typcategory = 'A', typdelim = ',', typname = "_json", typelem = json } +array_jsonOid :: Oid+array_jsonOid = Oid 199+{-# INLINE array_jsonOid #-}+ array_line :: TypeInfo array_line = Array {- typoid = Oid 629,+ typoid = array_lineOid, typcategory = 'A', typdelim = ',', typname = "_line", typelem = line } +array_lineOid :: Oid+array_lineOid = Oid 629+{-# INLINE array_lineOid #-}+ array_cidr :: TypeInfo array_cidr = Array {- typoid = Oid 651,+ typoid = array_cidrOid, typcategory = 'A', typdelim = ',', typname = "_cidr", typelem = cidr } +array_cidrOid :: Oid+array_cidrOid = Oid 651+{-# INLINE array_cidrOid #-}+ array_circle :: TypeInfo array_circle = Array {- typoid = Oid 719,+ typoid = array_circleOid, typcategory = 'A', typdelim = ',', typname = "_circle", typelem = circle } +array_circleOid :: Oid+array_circleOid = Oid 719+{-# INLINE array_circleOid #-}+ array_money :: TypeInfo array_money = Array {- typoid = Oid 791,+ typoid = array_moneyOid, typcategory = 'A', typdelim = ',', typname = "_money", typelem = money } +array_moneyOid :: Oid+array_moneyOid = Oid 791+{-# INLINE array_moneyOid #-}+ array_bool :: TypeInfo array_bool = Array {- typoid = Oid 1000,+ typoid = array_boolOid, typcategory = 'A', typdelim = ',', typname = "_bool", typelem = bool } +array_boolOid :: Oid+array_boolOid = Oid 1000+{-# INLINE array_boolOid #-}+ array_bytea :: TypeInfo array_bytea = Array {- typoid = Oid 1001,+ typoid = array_byteaOid, typcategory = 'A', typdelim = ',', typname = "_bytea", typelem = bytea } +array_byteaOid :: Oid+array_byteaOid = Oid 1001+{-# INLINE array_byteaOid #-}+ array_char :: TypeInfo array_char = Array {- typoid = Oid 1002,+ typoid = array_charOid, typcategory = 'A', typdelim = ',', typname = "_char", typelem = char } +array_charOid :: Oid+array_charOid = Oid 1002+{-# INLINE array_charOid #-}+ array_name :: TypeInfo array_name = Array {- typoid = Oid 1003,+ typoid = array_nameOid, typcategory = 'A', typdelim = ',', typname = "_name", typelem = name } +array_nameOid :: Oid+array_nameOid = Oid 1003+{-# INLINE array_nameOid #-}+ array_int2 :: TypeInfo array_int2 = Array {- typoid = Oid 1005,+ typoid = array_int2Oid, typcategory = 'A', typdelim = ',', typname = "_int2", typelem = int2 } +array_int2Oid :: Oid+array_int2Oid = Oid 1005+{-# INLINE array_int2Oid #-}+ array_int2vector :: TypeInfo array_int2vector = Array {- typoid = Oid 1006,+ typoid = array_int2vectorOid, typcategory = 'A', typdelim = ',', typname = "_int2vector", typelem = int2vector } +array_int2vectorOid :: Oid+array_int2vectorOid = Oid 1006+{-# INLINE array_int2vectorOid #-}+ array_int4 :: TypeInfo array_int4 = Array {- typoid = Oid 1007,+ typoid = array_int4Oid, typcategory = 'A', typdelim = ',', typname = "_int4", typelem = int4 } +array_int4Oid :: Oid+array_int4Oid = Oid 1007+{-# INLINE array_int4Oid #-}+ array_regproc :: TypeInfo array_regproc = Array {- typoid = Oid 1008,+ typoid = array_regprocOid, typcategory = 'A', typdelim = ',', typname = "_regproc", typelem = regproc } +array_regprocOid :: Oid+array_regprocOid = Oid 1008+{-# INLINE array_regprocOid #-}+ array_text :: TypeInfo array_text = Array {- typoid = Oid 1009,+ typoid = array_textOid, typcategory = 'A', typdelim = ',', typname = "_text", typelem = text } +array_textOid :: Oid+array_textOid = Oid 1009+{-# INLINE array_textOid #-}+ array_tid :: TypeInfo array_tid = Array {- typoid = Oid 1010,+ typoid = array_tidOid, typcategory = 'A', typdelim = ',', typname = "_tid", typelem = tid } +array_tidOid :: Oid+array_tidOid = Oid 1010+{-# INLINE array_tidOid #-}+ array_xid :: TypeInfo array_xid = Array {- typoid = Oid 1011,+ typoid = array_xidOid, typcategory = 'A', typdelim = ',', typname = "_xid", typelem = xid } +array_xidOid :: Oid+array_xidOid = Oid 1011+{-# INLINE array_xidOid #-}+ array_cid :: TypeInfo array_cid = Array {- typoid = Oid 1012,+ typoid = array_cidOid, typcategory = 'A', typdelim = ',', typname = "_cid", typelem = cid } +array_cidOid :: Oid+array_cidOid = Oid 1012+{-# INLINE array_cidOid #-}+ array_oidvector :: TypeInfo array_oidvector = Array {- typoid = Oid 1013,+ typoid = array_oidvectorOid, typcategory = 'A', typdelim = ',', typname = "_oidvector", typelem = oidvector } +array_oidvectorOid :: Oid+array_oidvectorOid = Oid 1013+{-# INLINE array_oidvectorOid #-}+ array_bpchar :: TypeInfo array_bpchar = Array {- typoid = Oid 1014,+ typoid = array_bpcharOid, typcategory = 'A', typdelim = ',', typname = "_bpchar", typelem = bpchar } +array_bpcharOid :: Oid+array_bpcharOid = Oid 1014+{-# INLINE array_bpcharOid #-}+ array_varchar :: TypeInfo array_varchar = Array {- typoid = Oid 1015,+ typoid = array_varcharOid, typcategory = 'A', typdelim = ',', typname = "_varchar", typelem = varchar } +array_varcharOid :: Oid+array_varcharOid = Oid 1015+{-# INLINE array_varcharOid #-}+ array_int8 :: TypeInfo array_int8 = Array {- typoid = Oid 1016,+ typoid = array_int8Oid, typcategory = 'A', typdelim = ',', typname = "_int8", typelem = int8 } +array_int8Oid :: Oid+array_int8Oid = Oid 1016+{-# INLINE array_int8Oid #-}+ array_point :: TypeInfo array_point = Array {- typoid = Oid 1017,+ typoid = array_pointOid, typcategory = 'A', typdelim = ',', typname = "_point", typelem = point } +array_pointOid :: Oid+array_pointOid = Oid 1017+{-# INLINE array_pointOid #-}+ array_lseg :: TypeInfo array_lseg = Array {- typoid = Oid 1018,+ typoid = array_lsegOid, typcategory = 'A', typdelim = ',', typname = "_lseg", typelem = lseg } +array_lsegOid :: Oid+array_lsegOid = Oid 1018+{-# INLINE array_lsegOid #-}+ array_path :: TypeInfo array_path = Array {- typoid = Oid 1019,+ typoid = array_pathOid, typcategory = 'A', typdelim = ',', typname = "_path", typelem = path } +array_pathOid :: Oid+array_pathOid = Oid 1019+{-# INLINE array_pathOid #-}+ array_box :: TypeInfo array_box = Array {- typoid = Oid 1020,+ typoid = array_boxOid, typcategory = 'A', typdelim = ';', typname = "_box", typelem = box } +array_boxOid :: Oid+array_boxOid = Oid 1020+{-# INLINE array_boxOid #-}+ array_float4 :: TypeInfo array_float4 = Array {- typoid = Oid 1021,+ typoid = array_float4Oid, typcategory = 'A', typdelim = ',', typname = "_float4", typelem = float4 } +array_float4Oid :: Oid+array_float4Oid = Oid 1021+{-# INLINE array_float4Oid #-}+ array_float8 :: TypeInfo array_float8 = Array {- typoid = Oid 1022,+ typoid = array_float8Oid, typcategory = 'A', typdelim = ',', typname = "_float8", typelem = float8 } +array_float8Oid :: Oid+array_float8Oid = Oid 1022+{-# INLINE array_float8Oid #-}+ array_polygon :: TypeInfo array_polygon = Array {- typoid = Oid 1027,+ typoid = array_polygonOid, typcategory = 'A', typdelim = ',', typname = "_polygon", typelem = polygon } +array_polygonOid :: Oid+array_polygonOid = Oid 1027+{-# INLINE array_polygonOid #-}+ array_oid :: TypeInfo array_oid = Array {- typoid = Oid 1028,+ typoid = array_oidOid, typcategory = 'A', typdelim = ',', typname = "_oid", typelem = oid } +array_oidOid :: Oid+array_oidOid = Oid 1028+{-# INLINE array_oidOid #-}+ array_macaddr :: TypeInfo array_macaddr = Array {- typoid = Oid 1040,+ typoid = array_macaddrOid, typcategory = 'A', typdelim = ',', typname = "_macaddr", typelem = macaddr } +array_macaddrOid :: Oid+array_macaddrOid = Oid 1040+{-# INLINE array_macaddrOid #-}+ array_inet :: TypeInfo array_inet = Array {- typoid = Oid 1041,+ typoid = array_inetOid, typcategory = 'A', typdelim = ',', typname = "_inet", typelem = inet } +array_inetOid :: Oid+array_inetOid = Oid 1041+{-# INLINE array_inetOid #-}+ array_timestamp :: TypeInfo array_timestamp = Array {- typoid = Oid 1115,+ typoid = array_timestampOid, typcategory = 'A', typdelim = ',', typname = "_timestamp", typelem = timestamp } +array_timestampOid :: Oid+array_timestampOid = Oid 1115+{-# INLINE array_timestampOid #-}+ array_date :: TypeInfo array_date = Array {- typoid = Oid 1182,+ typoid = array_dateOid, typcategory = 'A', typdelim = ',', typname = "_date", typelem = date } +array_dateOid :: Oid+array_dateOid = Oid 1182+{-# INLINE array_dateOid #-}+ array_time :: TypeInfo array_time = Array {- typoid = Oid 1183,+ typoid = array_timeOid, typcategory = 'A', typdelim = ',', typname = "_time", typelem = time } +array_timeOid :: Oid+array_timeOid = Oid 1183+{-# INLINE array_timeOid #-}+ array_timestamptz :: TypeInfo array_timestamptz = Array {- typoid = Oid 1185,+ typoid = array_timestamptzOid, typcategory = 'A', typdelim = ',', typname = "_timestamptz", typelem = timestamptz } +array_timestamptzOid :: Oid+array_timestamptzOid = Oid 1185+{-# INLINE array_timestamptzOid #-}+ array_interval :: TypeInfo array_interval = Array {- typoid = Oid 1187,+ typoid = array_intervalOid, typcategory = 'A', typdelim = ',', typname = "_interval", typelem = interval } +array_intervalOid :: Oid+array_intervalOid = Oid 1187+{-# INLINE array_intervalOid #-}+ array_numeric :: TypeInfo array_numeric = Array {- typoid = Oid 1231,+ typoid = array_numericOid, typcategory = 'A', typdelim = ',', typname = "_numeric", typelem = numeric } +array_numericOid :: Oid+array_numericOid = Oid 1231+{-# INLINE array_numericOid #-}+ array_timetz :: TypeInfo array_timetz = Array {- typoid = Oid 1270,+ typoid = array_timetzOid, typcategory = 'A', typdelim = ',', typname = "_timetz", typelem = timetz } +array_timetzOid :: Oid+array_timetzOid = Oid 1270+{-# INLINE array_timetzOid #-}+ array_bit :: TypeInfo array_bit = Array {- typoid = Oid 1561,+ typoid = array_bitOid, typcategory = 'A', typdelim = ',', typname = "_bit", typelem = bit } +array_bitOid :: Oid+array_bitOid = Oid 1561+{-# INLINE array_bitOid #-}+ array_varbit :: TypeInfo array_varbit = Array {- typoid = Oid 1563,+ typoid = array_varbitOid, typcategory = 'A', typdelim = ',', typname = "_varbit", typelem = varbit } +array_varbitOid :: Oid+array_varbitOid = Oid 1563+{-# INLINE array_varbitOid #-}+ array_refcursor :: TypeInfo array_refcursor = Array {- typoid = Oid 2201,+ typoid = array_refcursorOid, typcategory = 'A', typdelim = ',', typname = "_refcursor", typelem = refcursor } +array_refcursorOid :: Oid+array_refcursorOid = Oid 2201+{-# INLINE array_refcursorOid #-}+ array_regprocedure :: TypeInfo array_regprocedure = Array {- typoid = Oid 2207,+ typoid = array_regprocedureOid, typcategory = 'A', typdelim = ',', typname = "_regprocedure", typelem = regprocedure } +array_regprocedureOid :: Oid+array_regprocedureOid = Oid 2207+{-# INLINE array_regprocedureOid #-}+ array_regoper :: TypeInfo array_regoper = Array {- typoid = Oid 2208,+ typoid = array_regoperOid, typcategory = 'A', typdelim = ',', typname = "_regoper", typelem = regoper } +array_regoperOid :: Oid+array_regoperOid = Oid 2208+{-# INLINE array_regoperOid #-}+ array_regoperator :: TypeInfo array_regoperator = Array {- typoid = Oid 2209,+ typoid = array_regoperatorOid, typcategory = 'A', typdelim = ',', typname = "_regoperator", typelem = regoperator } +array_regoperatorOid :: Oid+array_regoperatorOid = Oid 2209+{-# INLINE array_regoperatorOid #-}+ array_regclass :: TypeInfo array_regclass = Array {- typoid = Oid 2210,+ typoid = array_regclassOid, typcategory = 'A', typdelim = ',', typname = "_regclass", typelem = regclass } +array_regclassOid :: Oid+array_regclassOid = Oid 2210+{-# INLINE array_regclassOid #-}+ array_regtype :: TypeInfo array_regtype = Array {- typoid = Oid 2211,+ typoid = array_regtypeOid, typcategory = 'A', typdelim = ',', typname = "_regtype", typelem = regtype } +array_regtypeOid :: Oid+array_regtypeOid = Oid 2211+{-# INLINE array_regtypeOid #-}+ array_uuid :: TypeInfo array_uuid = Array {- typoid = Oid 2951,+ typoid = array_uuidOid, typcategory = 'A', typdelim = ',', typname = "_uuid", typelem = uuid } +array_uuidOid :: Oid+array_uuidOid = Oid 2951+{-# INLINE array_uuidOid #-}+ array_jsonb :: TypeInfo array_jsonb = Array {- typoid = Oid 3807,+ typoid = array_jsonbOid, typcategory = 'A', typdelim = ',', typname = "_jsonb", typelem = jsonb } +array_jsonbOid :: Oid+array_jsonbOid = Oid 3807+{-# INLINE array_jsonbOid #-}+ int4range :: TypeInfo int4range = Range {- typoid = Oid 3904,+ typoid = int4rangeOid, typcategory = 'R', typdelim = ',', typname = "int4range", rngsubtype = int4 } +int4rangeOid :: Oid+int4rangeOid = Oid 3904+{-# INLINE int4rangeOid #-}+ _int4range :: TypeInfo _int4range = Array {- typoid = Oid 3905,+ typoid = _int4rangeOid, typcategory = 'A', typdelim = ',', typname = "_int4range", typelem = int4range } +_int4rangeOid :: Oid+_int4rangeOid = Oid 3905+{-# INLINE _int4rangeOid #-}+ numrange :: TypeInfo numrange = Range {- typoid = Oid 3906,+ typoid = numrangeOid, typcategory = 'R', typdelim = ',', typname = "numrange", rngsubtype = numeric } +numrangeOid :: Oid+numrangeOid = Oid 3906+{-# INLINE numrangeOid #-}+ _numrange :: TypeInfo _numrange = Array {- typoid = Oid 3907,+ typoid = _numrangeOid, typcategory = 'A', typdelim = ',', typname = "_numrange", typelem = numrange } +_numrangeOid :: Oid+_numrangeOid = Oid 3907+{-# INLINE _numrangeOid #-}+ tsrange :: TypeInfo tsrange = Range {- typoid = Oid 3908,+ typoid = tsrangeOid, typcategory = 'R', typdelim = ',', typname = "tsrange", rngsubtype = timestamp } +tsrangeOid :: Oid+tsrangeOid = Oid 3908+{-# INLINE tsrangeOid #-}+ _tsrange :: TypeInfo _tsrange = Array {- typoid = Oid 3909,+ typoid = _tsrangeOid, typcategory = 'A', typdelim = ',', typname = "_tsrange", typelem = tsrange } +_tsrangeOid :: Oid+_tsrangeOid = Oid 3909+{-# INLINE _tsrangeOid #-}+ tstzrange :: TypeInfo tstzrange = Range {- typoid = Oid 3910,+ typoid = tstzrangeOid, typcategory = 'R', typdelim = ',', typname = "tstzrange", rngsubtype = timestamptz } +tstzrangeOid :: Oid+tstzrangeOid = Oid 3910+{-# INLINE tstzrangeOid #-}+ _tstzrange :: TypeInfo _tstzrange = Array {- typoid = Oid 3911,+ typoid = _tstzrangeOid, typcategory = 'A', typdelim = ',', typname = "_tstzrange", typelem = tstzrange } +_tstzrangeOid :: Oid+_tstzrangeOid = Oid 3911+{-# INLINE _tstzrangeOid #-}+ daterange :: TypeInfo daterange = Range {- typoid = Oid 3912,+ typoid = daterangeOid, typcategory = 'R', typdelim = ',', typname = "daterange", rngsubtype = date } +daterangeOid :: Oid+daterangeOid = Oid 3912+{-# INLINE daterangeOid #-}+ _daterange :: TypeInfo _daterange = Array {- typoid = Oid 3913,+ typoid = _daterangeOid, typcategory = 'A', typdelim = ',', typname = "_daterange", typelem = daterange } +_daterangeOid :: Oid+_daterangeOid = Oid 3913+{-# INLINE _daterangeOid #-}+ int8range :: TypeInfo int8range = Range {- typoid = Oid 3926,+ typoid = int8rangeOid, typcategory = 'R', typdelim = ',', typname = "int8range", rngsubtype = int8 } +int8rangeOid :: Oid+int8rangeOid = Oid 3926+{-# INLINE int8rangeOid #-}+ _int8range :: TypeInfo _int8range = Array {- typoid = Oid 3927,+ typoid = _int8rangeOid, typcategory = 'A', typdelim = ',', typname = "_int8range", typelem = int8range }++_int8rangeOid :: Oid+_int8rangeOid = Oid 3927+{-# INLINE _int8rangeOid #-}
+ test/Inspection.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -dsuppress-idinfo -dsuppress-coercions -dsuppress-type-applications -dsuppress-module-prefixes -dsuppress-type-signatures #-}+-- {-# OPTIONS_GHC -dsuppress-uniques #-}+{-# OPTIONS_GHC -fplugin=Test.Inspection.Plugin #-}+module Main where++import Test.Inspection+import Test.Tasty+import Test.Tasty.HUnit++import qualified Database.PostgreSQL.LibPQ as PQ+import Database.PostgreSQL.Simple.FromField+import Database.PostgreSQL.Simple.TypeInfo as TI+import Database.PostgreSQL.Simple.TypeInfo.Macro+import qualified Database.PostgreSQL.Simple.TypeInfo.Static as TI++-------------------------------------------------------------------------------+-- Inspection tests+-------------------------------------------------------------------------------++-- # doesn't work :(+#define TH_MKCOMPATS3(a,b,c) $(mkCompats [TI.a,TI.b,TI.c])+#define IN_MKCOMPATS3(a,b,c) (eq TI.a \/ eq TI.b \/ eq TI.c)++#define TH_INLINETYPOID(n) eq $(inlineTypoid TI.n)+#define IN_INLINETYPOID(n) eq TI.n++-- eta-expansion is required+lhs01, rhs01 :: PQ.Oid -> Bool+lhs01 = TH_MKCOMPATS3(name,text,char)+rhs01 = IN_MKCOMPATS3(nameOid,textOid,charOid)++lhs02, rhs02 :: PQ.Oid -> Bool+lhs02 = TH_INLINETYPOID(name)+rhs02 = IN_INLINETYPOID(nameOid)++eq :: PQ.Oid -> PQ.Oid -> Bool+eq = (==)+{-# INLINE eq #-}++infixr 2 \/+(\/) :: (PQ.Oid -> Bool)+ -> (PQ.Oid -> Bool)+ -> (PQ.Oid -> Bool)+f \/ g = \x -> f x || g x+{-# INLINE (\/) #-}++inspectionTests :: TestTree+inspectionTests = testGroup "inspection"+ [ testCase "mkCompats" $+ assertSuccess $(inspectTest $ 'lhs01 === 'rhs01)+ + -- byteaOid isn't inlined?+ , testCase "inlineTypoid" $+ assertFailure' $(inspectTest $ 'lhs02 ==- 'rhs02)+ ]++assertSuccess :: Result -> IO ()+assertSuccess (Success _) = return ()+assertSuccess (Failure err) = assertFailure err++assertFailure' :: Result -> IO ()+assertFailure' (Success err) = assertFailure err+assertFailure' (Failure _) = return ()++-------------------------------------------------------------------------------+-- Main+-------------------------------------------------------------------------------++main :: IO ()+main = defaultMain $ testGroup "tests"+ [ inspectionTests+ ]
test/Main.hs view
@@ -4,18 +4,21 @@ {-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE ScopedTypeVariables #-} import Common+import Database.PostgreSQL.Simple.Copy import Database.PostgreSQL.Simple.FromField (FromField)-import Database.PostgreSQL.Simple.Types(Query(..),Values(..)) import Database.PostgreSQL.Simple.HStore-import Database.PostgreSQL.Simple.Copy+import Database.PostgreSQL.Simple.Internal (breakOnSingleQuestionMark)+import Database.PostgreSQL.Simple.Types(Query(..),Values(..), PGArray(..)) import qualified Database.PostgreSQL.Simple.Transaction as ST import Control.Applicative import Control.Exception as E import Control.Monad import Data.Char-import Data.List (sort)+import Data.List (concat, sort) import Data.IORef+import Data.Monoid ((<>))+import Data.String (fromString) import Data.Typeable import GHC.Generics (Generic) @@ -44,26 +47,27 @@ tests env = testGroup "tests" $ map ($ env) [ testBytea- , testCase "ExecuteMany" . testExecuteMany- , testCase "Fold" . testFold- , testCase "Notify" . testNotify- , testCase "Serializable" . testSerializable- , testCase "Time" . testTime- , testCase "Array" . testArray- , testCase "Array of nullables" . testNullableArray- , testCase "HStore" . testHStore- , testCase "citext" . testCIText- , testCase "JSON" . testJSON- , testCase "Savepoint" . testSavepoint- , testCase "Unicode" . testUnicode- , testCase "Values" . testValues- , testCase "Copy" . testCopy+ , testCase "ExecuteMany" . testExecuteMany+ , testCase "Fold" . testFold+ , testCase "Notify" . testNotify+ , testCase "Serializable" . testSerializable+ , testCase "Time" . testTime+ , testCase "Array" . testArray+ , testCase "Array of nullables" . testNullableArray+ , testCase "HStore" . testHStore+ , testCase "citext" . testCIText+ , testCase "JSON" . testJSON+ , testCase "Question mark escape" . testQM+ , testCase "Savepoint" . testSavepoint+ , testCase "Unicode" . testUnicode+ , testCase "Values" . testValues+ , testCase "Copy" . testCopy , testCopyFailures- , testCase "Double" . testDouble- , testCase "1-ary generic" . testGeneric1- , testCase "2-ary generic" . testGeneric2- , testCase "3-ary generic" . testGeneric3- , testCase "Timeout" . testTimeout+ , testCase "Double" . testDouble+ , testCase "1-ary generic" . testGeneric1+ , testCase "2-ary generic" . testGeneric2+ , testCase "3-ary generic" . testGeneric3+ , testCase "Timeout" . testTimeout ] testBytea :: TestEnv -> TestTree@@ -234,6 +238,56 @@ js' <- query conn "SELECT ?::json" js [js] @?= js' +testQM :: TestEnv -> Assertion+testQM TestEnv{..} = do+ -- Just test on a single string+ let testQuery' b = "testing for ?" <> b <> " and making sure "+ testQueryDoubleQM = testQuery' "?"+ testQueryRest = "? is substituted"+ testQuery = fromString $ testQueryDoubleQM <> testQueryRest+ -- expect the entire first part with double QMs replaced with literal '?'+ expected = (fromString $ testQuery' "", fromString testQueryRest)+ tried = breakOnSingleQuestionMark testQuery+ errMsg = concat+ [ "Failed to break on single question mark exclusively:\n"+ , "expected: ", show expected+ , "result: ", show tried+ ]+ assertBool errMsg $ tried == expected++ -- Let's also test the question mark operators in action+ -- ? -> Does the string exist as a top-level key within the JSON value?+ positiveQuery "SELECT ?::jsonb ?? ?" (testObj, "foo" :: Text)+ negativeQuery "SELECT ?::jsonb ?? ?" (testObj, "baz" :: Text)+ negativeQuery "SELECT ?::jsonb ?? ?" (toJSON numArray, "1" :: Text)+ -- ?| -> Do any of these array strings exist as top-level keys?+ positiveQuery "SELECT ?::jsonb ??| ?" (testObj, PGArray ["nope","bar","6" :: Text])+ negativeQuery "SELECT ?::jsonb ??| ?" (testObj, PGArray ["nope","6" :: Text])+ negativeQuery "SELECT ?::jsonb ??| ?" (toJSON numArray, PGArray ["1","2","6" :: Text])+ -- ?& -> Do all of these array strings exist as top-level keys?+ positiveQuery "SELECT ?::jsonb ??& ?" (testObj, PGArray ["foo","bar","quux" :: Text])+ positiveQuery "SELECT ?::jsonb ??& ?" (testObj, PGArray ["foo","bar" :: Text])+ negativeQuery "SELECT ?::jsonb ??& ?" (testObj, PGArray ["foo","bar","baz" :: Text])+ negativeQuery "SELECT ?::jsonb ??& ?" (toJSON numArray, PGArray ["1","2","3","4","5" :: Text])+ -- Format error for 2 question marks, not 4+ True <- expectError (isFormatError 2) $+ (query conn "SELECT ?::jsonb ?? ?" $ Only testObj :: IO [Only Bool])+ return ()+ where positiveQuery :: ToRow a => Query -> a -> Assertion+ positiveQuery = boolQuery True+ negativeQuery :: ToRow a => Query -> a -> Assertion+ negativeQuery = boolQuery False+ numArray :: [Int]+ numArray = [1,2,3,4,5]+ boolQuery :: ToRow a => Bool -> Query -> a -> Assertion+ boolQuery b t x = do+ a <- query conn t x+ [Only b] @?= a+ testObj = toJSON (Map.fromList [("foo",toJSON (1 :: Int))+ ,("bar",String "baz")+ ,("quux",toJSON [1 :: Int,2,3,4,5])] :: Map Text Value+ )+ testSavepoint :: TestEnv -> Assertion testSavepoint TestEnv{..} = do True <- expectError ST.isNoActiveTransactionError $@@ -478,6 +532,14 @@ isSyntaxError :: SqlError -> Bool isSyntaxError SqlError{..} = sqlState == "42601" +isFormatError :: Int -> FormatError -> Bool+isFormatError i FormatError{..}+ | null fmtMessage = False+ | otherwise = fmtMessage == concat [ show i+ , " single '?' characters, but "+ , show (length fmtParams)+ , " parameters"+ ] ------------------------------------------------------------------------ -- | Action for connecting to the database that will be used for testing.