pg-store 0.0.1 → 0.1.0

raw patch · 16 files changed

+1574/−1263 lines, 16 filesdep +mtldep +timedep −transformersdep ~basedep ~template-haskellPVP ok

version bump matches the API change (PVP)

Dependencies added: mtl, time

Dependencies removed: transformers

Dependency ranges changed: base, template-haskell

API changes (from Hackage documentation)

Files

• pg-store.cabal +18/−18
• src/Database/PostgreSQL/Store.hs +36/−18
• src/Database/PostgreSQL/Store/Columns.hs +219/−196
• src/Database/PostgreSQL/Store/Errand.hs +124/−41
• src/Database/PostgreSQL/Store/OIDs.hs +91/−0
• src/Database/PostgreSQL/Store/Query.hs +361/−264
• src/Database/PostgreSQL/Store/Result.hs +52/−162
• src/Database/PostgreSQL/Store/Table.hs +292/−287
• tests/Database/PostgreSQL/Store/ColumnsSpec.hs +0/−121
• tests/Database/PostgreSQL/Store/QuerySpec.hs +0/−36
• tests/Database/PostgreSQL/Store/TableSpec.hs +0/−94
• tests/Main.hs +15/−26
• tests/Test/Database/PostgreSQL/Store.hs +17/−0
• tests/Test/Database/PostgreSQL/Store/Columns.hs +117/−0
• tests/Test/Database/PostgreSQL/Store/Query.hs +92/−0
• tests/Test/Database/PostgreSQL/Store/Table.hs +140/−0

@@ -1,8 +1,8 @@ name:                pg-store-version:             0.0.1+version:             0.1.0 category:            Database-synopsis:            Dead simple storage interface to PostgreSQL-description:         Dead simple storage interface to PostgreSQL+synopsis:            Simple storage interface to PostgreSQL+description:         Simple storage interface to PostgreSQL homepage:            https://github.com/vapourismo/pg-store license:             BSD3 license-file:        LICENSE@@ -17,28 +17,28 @@   location: https://github.com/vapourismo/pg-store.git  library-  ghc-options:      -Wall -fprof-auto -fno-warn-unused-do-bind -fno-warn-tabs-                    -fno-warn-name-shadowing+  ghc-options:      -Wall -fno-warn-unused-do-bind -fno-warn-tabs -fno-warn-name-shadowing   default-language: Haskell2010-  build-depends:    base >= 4.8.2.0 && < 5,-                    template-haskell, bytestring, text, postgresql-libpq, transformers,-                    attoparsec+  build-depends:    base >= 4.9 && < 5,+                    template-haskell >= 2.11 && < 3,+                    bytestring, text, postgresql-libpq, attoparsec, mtl, time   hs-source-dirs:   src-  exposed-modules:  Database.PostgreSQL.Store,-                    Database.PostgreSQL.Store.Table,+  exposed-modules:  Database.PostgreSQL.Store.Result,                     Database.PostgreSQL.Store.Columns,                     Database.PostgreSQL.Store.Query,-                    Database.PostgreSQL.Store.Result,-                    Database.PostgreSQL.Store.Errand+                    Database.PostgreSQL.Store.Errand,+                    Database.PostgreSQL.Store.Table,+                    Database.PostgreSQL.Store.OIDs,+                    Database.PostgreSQL.Store  test-suite tests   type:             exitcode-stdio-1.0-  ghc-options:      -Wall -fprof-auto -fno-warn-unused-do-bind -fno-warn-tabs-                    -fno-warn-name-shadowing+  ghc-options:      -Wall -fno-warn-unused-do-bind -fno-warn-tabs -fno-warn-name-shadowing   default-language: Haskell2010-  build-depends:    base, pg-store, hspec, QuickCheck, bytestring, text, postgresql-libpq+  build-depends:    base, pg-store, hspec, QuickCheck, bytestring, text, postgresql-libpq, mtl   hs-source-dirs:   tests-  other-modules:    Database.PostgreSQL.Store.ColumnsSpec,-                    Database.PostgreSQL.Store.TableSpec,-                    Database.PostgreSQL.Store.QuerySpec+  other-modules:    Test.Database.PostgreSQL.Store.Query,+                    Test.Database.PostgreSQL.Store.Columns,+                    Test.Database.PostgreSQL.Store.Table,+                    Test.Database.PostgreSQL.Store   main-is:          Main.hs

@@ -4,31 +4,49 @@ -- License:    BSD3 -- Maintainer: Ole Krüger <ole@vprsm.de> module Database.PostgreSQL.Store (-	-- * Tables-	TableConstraint (..),-	mkTable,-	Row (..),-	Reference (..),+	-- * Errands+	Errand,+	ErrandError (..),+	ErrorCode (..),+	ExecStatus (..),+	runErrand,+	execute,+	query,+	query_,+	queryWith,  	-- * Queries 	Query (..), 	pgsq,-	mkCreateQuery,+	pgss, -	-- * Errands+	QueryTable (..),+	SelectorElement (..),++	-- * Values+	Value (..),+	Column (..),++	-- * Results+	Result (..),+	ResultProcessor, 	ResultError (..),-	ErrandError (..),-	Errand,-	runErrand,-	query,-	query_,-	insert,-	find,-	update,-	delete+	skipColumn,+	unpackColumn,++	Single (..),+	Reference (..),++	-- * Tables+	Table (..),+	mkCreateQuery,++	mkTable,+	TableConstraint (..) ) where -import Database.PostgreSQL.Store.Table-import Database.PostgreSQL.Store.Query+import Database.PostgreSQL.Store.Columns import Database.PostgreSQL.Store.Errand+import Database.PostgreSQL.Store.Query import Database.PostgreSQL.Store.Result+import Database.PostgreSQL.Store.Table

@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedStrings, RecordWildCards, FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings, RecordWildCards, FlexibleInstances, TemplateHaskell #-}  -- | -- Module:     Database.PostgreSQL.Store.Columns@@ -10,85 +10,42 @@ 	Value (..),  	-- *-	ColumnDescription (..),-	makeColumnDescription,--	-- *-	sanitizeName,-	sanitizeName',-	identField,-	identField',--	-- *-	Column (..),+	Column (..) ) where -import           Language.Haskell.TH- import           Data.Int import           Data.Word import           Data.Bits+import           Data.Time import           Data.Monoid import           Data.Typeable-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import qualified Data.Text.Lazy as TL-import qualified Data.Text.Lazy.Encoding as TL-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as BL+import qualified Data.Text                      as T+import qualified Data.Text.Encoding             as T+import qualified Data.Text.Lazy                 as TL+import qualified Data.ByteString                as B+import qualified Data.ByteString.Char8          as C8+import qualified Data.ByteString.Lazy           as BL import           Data.ByteString.Builder import           Data.Attoparsec.ByteString import           Data.Attoparsec.ByteString.Char8 (signed, decimal) -import qualified Database.PostgreSQL.LibPQ as P+import           Database.PostgreSQL.LibPQ (Oid)+import qualified Database.PostgreSQL.Store.OIDs as OID  -- | Query parameter or value of a column - see 'pack' on how to generate 'Value's manually but --   conveniently. data Value 	= Value { 		-- | Type object identifier-		valueType :: P.Oid,+		valueType :: Oid,  		-- | Data value-		valueData :: B.ByteString,--		-- | Data format-		valueFormat :: P.Format+		valueData :: B.ByteString 	} 	| NullValue 	deriving (Show, Eq, Ord) --- | Description of a column-data ColumnDescription = ColumnDescription {-	-- | Type name (e.g. bool, integer)-	columnTypeName :: String,--	-- | Can the column be null?-	columnTypeNull :: Bool-} deriving (Show, Eq, Ord)---- | Generate column description in SQL. Think @CREATE TABLE@.-makeColumnDescription :: ColumnDescription -> String-makeColumnDescription ColumnDescription {..} =-	columnTypeName ++ (if columnTypeNull then "" else " NOT NULL")---- | Generate the sanitized representation of a name.-sanitizeName :: Name -> String-sanitizeName = show---- | Similiar to "sanitizeName" but encloses the name in quotes.-sanitizeName' :: Name -> String-sanitizeName' name = "\"" ++ sanitizeName name ++ "\""---- | Generate the name for the identifying field.-identField :: Name -> String-identField name = show name ++ "$id"---- | Similiar to "identField" but encloses the name in quotes.-identField' :: Name -> String-identField' name = "\"" ++ identField name ++ "\""---- | Column type+-- | Types which implement this type class may be used as column types. class Column a where 	-- | Pack column value. 	pack :: a -> Value@@ -96,192 +53,258 @@ 	-- | Unpack column value. 	unpack :: Value -> Maybe a -	-- | Descripe the column type.-	describeColumn :: Proxy a -> ColumnDescription+	-- | Name of the underlying SQL type.+	columnTypeName :: Proxy a -> String +	-- | May the column be NULL?+	columnAllowNull :: Proxy a -> Bool+	columnAllowNull _proxy = False++	-- | A condition that must hold true for the column.+	columnCheck :: Proxy a -> String -> Maybe String+	columnCheck _proxy _identifier = Nothing++	-- | Generate column description in SQL. Think @CREATE TABLE@.+	columnDescription :: Proxy a -> String -> String+	columnDescription proxy identifier =+		identifier ++ " " +++		columnTypeName proxy +++		if columnAllowNull proxy then "" else " NOT NULL" +++		case columnCheck proxy identifier of+			Just stmt -> " CHECK (" ++ stmt ++ ")"+			Nothing   -> ""++instance Column Value where+	pack = id+	unpack = Just+	columnTypeName _ = "blob"+ instance (Column a) => Column (Maybe a) where 	pack = maybe NullValue pack  	unpack NullValue = Just Nothing-	unpack val       = fmap Just (unpack val)+	unpack val       = Just <$> unpack val -	describeColumn proxy =-		(describeColumn (transformProxy proxy)) {columnTypeNull = True}-		where-			transformProxy :: Proxy (Maybe a) -> Proxy a-			transformProxy _ = Proxy+	columnTypeName proxy = columnTypeName ((const Proxy :: Proxy (Maybe b) -> Proxy b) proxy)+	columnAllowNull _    = True+	columnCheck proxy    = columnCheck ((const Proxy :: Proxy (Maybe b) -> Proxy b) proxy)  instance Column Bool where-	pack v =-		Value {-			valueType   = P.Oid 16,-			valueData   = if v then "true" else "false",-			valueFormat = P.Text-		}+	pack True = Value $(OID.bool) "true"+	pack _    = Value $(OID.bool) "false" -	unpack (Value (P.Oid 16) "true" P.Text) = Just True-	unpack (Value (P.Oid 16) "TRUE" P.Text) = Just True-	unpack (Value (P.Oid 16) "t"    P.Text) = Just True-	unpack (Value (P.Oid 16) "y"    P.Text) = Just True-	unpack (Value (P.Oid 16) "yes"  P.Text) = Just True-	unpack (Value (P.Oid 16) "on"   P.Text) = Just True-	unpack (Value (P.Oid 16) "1"    P.Text) = Just True-	unpack (Value (P.Oid 16) _      P.Text) = Just False-	unpack _                                = Nothing+	unpack (Value $(OID.bool) "true") = Just True+	unpack (Value $(OID.bool) "TRUE") = Just True+	unpack (Value $(OID.bool) "t"   ) = Just True+	unpack (Value $(OID.bool) "y"   ) = Just True+	unpack (Value $(OID.bool) "yes" ) = Just True+	unpack (Value $(OID.bool) "YES" ) = Just True+	unpack (Value $(OID.bool) "on"  ) = Just True+	unpack (Value $(OID.bool) "ON"  ) = Just True+	unpack (Value $(OID.bool) "1"   ) = Just True+	unpack (Value $(OID.bool) _     ) = Just False+	unpack _                          = Nothing -	describeColumn _ =-		ColumnDescription {-			columnTypeName = "bool",-			columnTypeNull = False-		}+	columnTypeName _ = "bool"  instance Column Int where-	pack n =-		Value {-			valueType   = P.Oid 23,-			valueData   = buildByteString intDec n,-			valueFormat = P.Text-		}+	pack n = Value $(OID.int8) (buildByteString intDec n) -	unpack (Value (P.Oid 21) dat P.Text) = parseMaybe (signed decimal) dat-	unpack (Value (P.Oid 23) dat P.Text) = parseMaybe (signed decimal) dat-	unpack _                             = Nothing+	unpack (Value $(OID.int2) dat) = parseMaybe (signed decimal) dat+	unpack (Value $(OID.int4) dat) = parseMaybe (signed decimal) dat+	unpack (Value $(OID.int8) dat) = parseMaybe (signed decimal) dat+	unpack _                       = Nothing -	describeColumn _ =-		ColumnDescription {-			columnTypeName = "integer",-			columnTypeNull = False-		}+	columnTypeName _ = "int8" +	columnCheck _ nm =+		Just (nm ++ " >= " ++ show (minBound :: Int) +++		      " AND " +++		      nm ++ " <= " ++ show (maxBound :: Int))+ instance Column Int8 where-	pack n =-		Value {-			valueType   = P.Oid 21,-			valueData   = buildByteString int8Dec n,-			valueFormat = P.Text-		}+	pack n = Value $(OID.int2) (buildByteString int8Dec n) -	unpack (Value (P.Oid 21) dat P.Text) = parseMaybe (signed decimal) dat-	unpack _                             = Nothing+	unpack (Value $(OID.int2) dat) = parseMaybe (signed decimal) dat+	unpack (Value $(OID.int4) dat) = parseMaybe (signed decimal) dat+	unpack (Value $(OID.int8) dat) = parseMaybe (signed decimal) dat+	unpack _                       = Nothing -	describeColumn _ =-		ColumnDescription {-			columnTypeName = "smallint",-			columnTypeNull = False-		}+	columnTypeName _ = "int2"  instance Column Int16 where-	pack n =-		Value {-			valueType   = P.Oid 21,-			valueData   = buildByteString int16Dec n,-			valueFormat = P.Text-		}+	pack n = Value $(OID.int2) (buildByteString int16Dec n) -	unpack (Value (P.Oid 21) dat P.Text) = parseMaybe (signed decimal) dat-	unpack _                             = Nothing+	unpack (Value $(OID.int2) dat) = parseMaybe (signed decimal) dat+	unpack (Value $(OID.int4) dat) = parseMaybe (signed decimal) dat+	unpack (Value $(OID.int8) dat) = parseMaybe (signed decimal) dat+	unpack _                       = Nothing -	describeColumn _ =-		ColumnDescription {-			columnTypeName = "smallint",-			columnTypeNull = False-		}+	columnTypeName _ = "int2"  instance Column Int32 where-	pack n =-		Value {-			valueType   = P.Oid 23,-			valueData   = buildByteString int32Dec n,-			valueFormat = P.Text-		}+	pack n = Value $(OID.int4) (buildByteString int32Dec n) -	unpack (Value (P.Oid 21) dat P.Text) = parseMaybe (signed decimal) dat-	unpack (Value (P.Oid 23) dat P.Text) = parseMaybe (signed decimal) dat-	unpack _                             = Nothing+	unpack (Value $(OID.int2) dat) = parseMaybe (signed decimal) dat+	unpack (Value $(OID.int4) dat) = parseMaybe (signed decimal) dat+	unpack (Value $(OID.int8) dat) = parseMaybe (signed decimal) dat+	unpack _                       = Nothing  -	describeColumn _ =-		ColumnDescription {-			columnTypeName = "integer",-			columnTypeNull = False-		}+	columnTypeName _ = "int4"  instance Column Int64 where-	pack n =-		Value {-			valueType   = P.Oid 20,-			valueData   = buildByteString int64Dec n,-			valueFormat = P.Text-		}+	pack n = Value $(OID.int8) (buildByteString int64Dec n) -	unpack (Value (P.Oid 20) dat P.Text) = parseMaybe (signed decimal) dat-	unpack (Value (P.Oid 21) dat P.Text) = parseMaybe (signed decimal) dat-	unpack (Value (P.Oid 23) dat P.Text) = parseMaybe (signed decimal) dat-	unpack _                             = Nothing+	unpack (Value $(OID.int2) dat) = parseMaybe (signed decimal) dat+	unpack (Value $(OID.int4) dat) = parseMaybe (signed decimal) dat+	unpack (Value $(OID.int8) dat) = parseMaybe (signed decimal) dat+	unpack _                       = Nothing -	describeColumn _ =-		ColumnDescription {-			columnTypeName = "bigint",-			columnTypeNull = False-		}+	columnTypeName _ = "int8" +-- | Does "Word" require to be stored in type "numeric"?+wordRequiresNumeric :: Bool+wordRequiresNumeric =+	-- int8 upper bound is 2^63 - 1 (9223372036854775807)+	(fromIntegral (maxBound :: Word) :: Integer) > 9223372036854775807++instance Column Word where+	pack n | wordRequiresNumeric = Value $(OID.numeric) (buildByteString wordDec n)+	       | otherwise           = Value $(OID.int8)    (buildByteString wordDec n)++	unpack (Value $(OID.int2)    dat) = parseMaybe decimal dat+	unpack (Value $(OID.int4)    dat) = parseMaybe decimal dat+	unpack (Value $(OID.int8)    dat) = parseMaybe decimal dat+	unpack (Value $(OID.numeric) dat) = parseMaybe decimal dat+	unpack _                          = Nothing++	columnTypeName _ = if wordRequiresNumeric then "numeric(20, 0)" else "int8"++	columnCheck _ nm =+		Just (nm ++ " >= 0 AND " ++ nm ++ " <= " ++ show (maxBound :: Word))++instance Column Word8 where+	pack n = Value $(OID.int2) (buildByteString word8Dec n)++	unpack (Value $(OID.int2) dat) = parseMaybe decimal dat+	unpack (Value $(OID.int4) dat) = parseMaybe decimal dat+	unpack (Value $(OID.int8) dat) = parseMaybe decimal dat+	unpack _                       = Nothing++	columnTypeName _ = "int2"++	columnCheck _ nm =+		Just (nm ++ " >= 0 AND " ++ nm ++ " <= " ++ show (maxBound :: Word8))++instance Column Word16 where+	pack n = Value $(OID.int4) (buildByteString word16Dec n)++	unpack (Value $(OID.int2) dat) = parseMaybe decimal dat+	unpack (Value $(OID.int4) dat) = parseMaybe decimal dat+	unpack (Value $(OID.int8) dat) = parseMaybe decimal dat+	unpack _                       = Nothing++	columnTypeName _ = "int4"++	columnCheck _ nm =+		Just (nm ++ " >= 0 AND " ++ nm ++ " <= " ++ show (maxBound :: Word16))++instance Column Word32 where+	pack n = Value $(OID.int8) (buildByteString word32Dec n)++	unpack (Value $(OID.int2) dat) = parseMaybe decimal dat+	unpack (Value $(OID.int4) dat) = parseMaybe decimal dat+	unpack (Value $(OID.int8) dat) = parseMaybe decimal dat+	unpack _                       = Nothing++	columnTypeName _ = "bigint"++	columnCheck _ nm =+		Just (nm ++ " >= 0 AND " ++ nm ++ " <= " ++ show (maxBound :: Word32))++instance Column Word64 where+	pack n = Value $(OID.numeric) (buildByteString word64Dec n)++	unpack (Value $(OID.int2)    dat) = parseMaybe decimal dat+	unpack (Value $(OID.int4)    dat) = parseMaybe decimal dat+	unpack (Value $(OID.int8)    dat) = parseMaybe decimal dat+	unpack (Value $(OID.numeric) dat) = parseMaybe decimal dat+	unpack _                          = Nothing++	columnTypeName _ = "numeric(20, 0)"++	columnCheck _ nm =+		Just (nm ++ " >= 0 AND " ++ nm ++ " <= " ++ show (maxBound :: Word64))++instance Column Integer where+	pack n = Value $(OID.numeric) (buildByteString integerDec n)++	unpack (Value $(OID.int2)    dat) = parseMaybe decimal dat+	unpack (Value $(OID.int4)    dat) = parseMaybe decimal dat+	unpack (Value $(OID.int8)    dat) = parseMaybe decimal dat+	unpack (Value $(OID.numeric) dat) = parseMaybe decimal dat+	unpack _                          = Nothing++	columnTypeName _ = "numeric"++instance Column UTCTime where+	pack t = Value $(OID.timestamp) (C8.pack (formatTime defaultTimeLocale "%F %T%Q" t))++	unpack (Value $(OID.timestamp) dat) =+		parseTimeM False defaultTimeLocale "%F %T%Q" (C8.unpack dat)+	unpack _ = Nothing++	columnTypeName _ = "timestamp"+ instance Column [Char] where-	pack str =-		pack (buildByteString stringUtf8 str)+	pack str = Value $(OID.text) (buildByteString stringUtf8 str) -	unpack val =-		T.unpack . T.decodeUtf8 <$> unpack val+	unpack (Value $(OID.varchar) dat) = pure (T.unpack (T.decodeUtf8 dat))+	unpack (Value $(OID.char)    dat) = pure (T.unpack (T.decodeUtf8 dat))+	unpack (Value $(OID.text)    dat) = pure (T.unpack (T.decodeUtf8 dat))+	unpack _                          = Nothing -	describeColumn _ =-		describeColumn (Proxy :: Proxy B.ByteString)+	columnTypeName _ = "text"  instance Column T.Text where-	pack txt =-		pack (T.encodeUtf8 txt)+	pack txt = Value $(OID.text) (T.encodeUtf8 txt) -	unpack val =-		T.decodeUtf8 <$> unpack val+	unpack (Value $(OID.varchar) dat) = pure (T.decodeUtf8 dat)+	unpack (Value $(OID.char)    dat) = pure (T.decodeUtf8 dat)+	unpack (Value $(OID.text)    dat) = pure (T.decodeUtf8 dat)+	unpack _                          = Nothing -	describeColumn _ =-		describeColumn (Proxy :: Proxy B.ByteString)+	columnTypeName _ = "text"  instance Column TL.Text where-	pack txt =-		pack (TL.encodeUtf8 txt)+	pack txt = pack (TL.toStrict txt) -	unpack val =-		TL.decodeUtf8 <$> unpack val+	unpack val = TL.fromStrict <$> unpack val -	describeColumn _ =-		describeColumn (Proxy :: Proxy BL.ByteString)+	columnTypeName _  = columnTypeName (Proxy :: Proxy T.Text)+	columnAllowNull _ = columnAllowNull (Proxy :: Proxy T.Text)+	columnCheck _     = columnCheck (Proxy :: Proxy T.Text)  instance Column B.ByteString where-	pack bs =-		Value {-			valueType   = P.Oid 17,-			valueData   = toTextByteArray bs,-			valueFormat = P.Text-		}+	pack bs = Value $(OID.bytea) (encodeByteaHex bs) -	unpack (Value (P.Oid 17) dat P.Binary) = pure dat-	unpack (Value (P.Oid 17) dat P.Text)   = fromTextByteArray dat-	unpack _                               = Nothing+	unpack (Value $(OID.varchar) dat) = pure dat+	unpack (Value $(OID.char)    dat) = pure dat+	unpack (Value $(OID.text)    dat) = pure dat+	unpack (Value $(OID.bytea)   dat) = decodeByteaHex dat+	unpack _                          = Nothing -	describeColumn _ =-		ColumnDescription {-			columnTypeName = "bytea",-			columnTypeNull = False-		}+	columnTypeName _ = "bytea"  instance Column BL.ByteString where-	pack bs =-		pack (BL.toStrict bs)+	pack bs = pack (BL.toStrict bs) -	unpack val =-		BL.fromStrict <$> unpack val+	unpack val = BL.fromStrict <$> unpack val -	describeColumn _ =-		describeColumn (Proxy :: Proxy B.ByteString)+	columnTypeName _  = columnTypeName (Proxy :: Proxy B.ByteString)+	columnAllowNull _ = columnAllowNull (Proxy :: Proxy B.ByteString)+	columnCheck _     = columnCheck (Proxy :: Proxy B.ByteString)  -- | Produce the two-digit hexadecimal representation of a 8-bit word. word8ToHex :: Word8 -> B.ByteString@@ -316,8 +339,8 @@ 			}  -- | Unpack a byte array in textual representation.-fromTextByteArray :: B.ByteString -> Maybe B.ByteString-fromTextByteArray bs+decodeByteaHex :: B.ByteString -> Maybe B.ByteString+decodeByteaHex bs 	| B.length bs >= 2 && mod (B.length bs) 2 == 0 && B.isPrefixOf "\\x" bs = 		Just (B.pack (unfoldHex (B.drop 2 bs))) 	| otherwise = Nothing@@ -326,8 +349,8 @@ 			unfoldHex bs = hexToWord8 (B.take 2 bs) : unfoldHex (B.drop 2 bs)  -- | Pack textual representation of a byte array.-toTextByteArray :: B.ByteString -> B.ByteString-toTextByteArray bs =+encodeByteaHex :: B.ByteString -> B.ByteString+encodeByteaHex bs = 	"\\x" <> B.concatMap word8ToHex bs  -- | Finish the parsing process.

@@ -1,4 +1,4 @@-{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving #-}  -- | -- Module:     Database.PostgreSQL.Store.Errand@@ -6,19 +6,29 @@ -- License:    BSD3 -- Maintainer: Ole Krüger <ole@vprsm.de> module Database.PostgreSQL.Store.Errand (+	-- * Errand 	ErrandError (..),+	ErrorCode (..),+	P.ExecStatus (..),+ 	Errand, 	runErrand,-	raiseErrandError,-	executeQuery,++	execute, 	query,-	query_+	query_,+	queryWith,++	-- * Result parser+	Result (..),+	Single (..) ) where -import           Control.Monad.Trans.Class-import           Control.Monad.Trans.Except-import           Control.Monad.Trans.Reader+import           Control.Monad.Trans+import           Control.Monad.Except+import           Control.Monad.Reader +import           Data.Maybe import qualified Data.ByteString           as B  import qualified Database.PostgreSQL.LibPQ as P@@ -29,60 +39,133 @@ -- | Error during errand data ErrandError 	= NoResult-	| ExecError P.ExecStatus (Maybe B.ByteString)-	| ResultError ResultError-	| UnexpectedEmptyResult+		-- ^ No 'Result' has been returned.+	| EmptyResult+		-- ^ Result set is empty. 	| UserError String+		-- ^ A user has thrown an error.+	| ExecError P.ExecStatus ErrorCode B.ByteString B.ByteString B.ByteString+		-- ^ Query execution failed.+	| ResultError ResultError+		-- ^ Result processing failed. 	deriving (Show, Eq) +-- | Error codes+data ErrorCode+	= UnknownErrorCause B.ByteString+	| IntegrityViolation+	| RestrictViolation+	| NotNullViolation+	| ForeignKeyViolation+	| UniqueViolation+	| CheckViolation+	| ExclusionViolation+	deriving (Show, Eq)+ -- | An interaction with the database-type Errand = ReaderT P.Connection (ExceptT ErrandError IO)+newtype Errand a = Errand (ReaderT P.Connection (ExceptT ErrandError IO) a)+	deriving (Functor, Applicative, Monad, MonadIO, MonadError ErrandError)  -- | Run an errand. runErrand :: P.Connection -> Errand a -> IO (Either ErrandError a)-runErrand con errand =+runErrand con (Errand errand) = 	runExceptT (runReaderT errand con) --- | Raise an error.-raiseErrandError :: ErrandError -> Errand a-raiseErrandError err =-	lift (ExceptT (pure (Left err)))+-- | Execute a query and return the internal raw result.+execute :: Query -> Errand P.Result+execute (Query statement params) = Errand . ReaderT $ \ con -> do+	res <- ExceptT $+		transformResult <$> P.execParams con statement (map transformParam params) P.Text+	status <- lift (P.resultStatus res) --- | Execute a query and return its result.-executeQuery :: Query -> Errand P.Result-executeQuery (Query statement params) = do-	con <- ask-	lift $ do-		res <- ExceptT (transformResult <$> P.execParams con statement transformedParams P.Text)-		status <- lift (P.resultStatus res)+	case status of+		P.CommandOk -> pure res+		P.TuplesOk  -> pure res -		case status of-			P.CommandOk -> pure res-			P.TuplesOk  -> pure res+		other -> do+			(state, msg, detail, hint) <- lift $+				(,,,) <$> P.resultErrorField res P.DiagSqlstate+				      <*> P.resultErrorField res P.DiagMessagePrimary+				      <*> P.resultErrorField res P.DiagMessageDetail+				      <*> P.resultErrorField res P.DiagMessageHint -			other -> do-				msg <- lift (P.resultErrorMessage res)-				throwE (ExecError other msg)+			let cause =+				case fromMaybe B.empty state of+					"23000" -> IntegrityViolation+					"23001" -> RestrictViolation+					"23502" -> NotNullViolation+					"23503" -> ForeignKeyViolation+					"23505" -> UniqueViolation+					"23514" -> CheckViolation+					"23P01" -> ExclusionViolation+					code    -> UnknownErrorCause code +			throwError (ExecError other+			                      cause+			                      (fromMaybe B.empty msg)+			                      (fromMaybe B.empty detail)+			                      (fromMaybe B.empty hint))+ 	where-		transformResult =-			maybe (Left NoResult) pure+		-- Turn 'Maybe P.Result' into 'Either ErrandError P.Result'+		transformResult = maybe (throwError NoResult) pure -		transformParam Value {..} = Just (valueType, valueData, valueFormat)-		transformParam NullValue  = Nothing+		-- Turn 'Value' into 'Maybe (P.Oid, B.ByteString, P.Format)'+		transformParam (Value typ dat) = Just (typ, dat, P.Text)+		transformParam NullValue       = Nothing -		transformedParams =-			map transformParam params+-- | Allows you to implement a custom result parser for your type.+--   'mkTable' can implement this for your type.+class Result a where+	queryResultProcessor :: ResultProcessor a +-- | Combine result parsers sequencially.+instance (Result a, Result b) => Result (a, b) where+	queryResultProcessor =+		(,) <$> queryResultProcessor <*> queryResultProcessor++instance (Result a, Result b, Result c) => Result (a, b, c) where+	queryResultProcessor =+		(,,) <$> queryResultProcessor <*> queryResultProcessor <*> queryResultProcessor++instance (Result a, Result b, Result c, Result d) => Result (a, b, c, d) where+	queryResultProcessor =+		(,,,) <$> queryResultProcessor <*> queryResultProcessor <*> queryResultProcessor <*> queryResultProcessor++instance (Result a, Result b, Result c, Result d, Result e) => Result (a, b, c, d, e) where+	queryResultProcessor =+		(,,,,) <$> queryResultProcessor <*> queryResultProcessor <*> queryResultProcessor <*> queryResultProcessor <*> queryResultProcessor++instance (Result a, Result b, Result c, Result d, Result e, Result f) => Result (a, b, c, d, e, f) where+	queryResultProcessor =+		(,,,,,) <$> queryResultProcessor <*> queryResultProcessor <*> queryResultProcessor <*> queryResultProcessor <*> queryResultProcessor <*> queryResultProcessor++instance (Result a, Result b, Result c, Result d, Result e, Result f, Result g) => Result (a, b, c, d, e, f, g) where+	queryResultProcessor =+		(,,,,,,) <$> queryResultProcessor <*> queryResultProcessor <*> queryResultProcessor <*> queryResultProcessor <*> queryResultProcessor <*> queryResultProcessor <*> queryResultProcessor+ -- | Execute a query and process its result set.--- It is essential that all fields required by the underlying result parser are present. query :: (Result a) => Query -> Errand [a]-query qry = do-	result <- executeQuery qry-	lift (withExceptT ResultError (runResultProcessor result resultProcessor))+query qry =+	queryWith qry queryResultProcessor --- | Execute a query.+-- | Execute a query and dismiss its result. query_ :: Query -> Errand () query_ qry =-	() <$ executeQuery qry+	() <$ execute qry +-- | Execute a query and process its result set using the provided result processor.+queryWith :: Query -> ResultProcessor a -> Errand [a]+queryWith qry proc = do+	result <- execute qry+	Errand (lift (withExceptT ResultError (processResult result proc)))++-- | Helper type to capture an single column.+newtype Single a = Single { fromSingle :: a }+	deriving (Eq, Ord)++instance (Show a) => Show (Single a) where+	show = show . fromSingle++instance (Column a) => Result (Single a) where+	queryResultProcessor = Single <$> unpackColumn

@@ -0,0 +1,91 @@+{-# LANGUAGE TemplateHaskell, QuasiQuotes, RankNTypes #-}++-- |+-- Module:     Database.PostgreSQL.Store.OIDs+-- Copyright:  (c) Ole Krüger 2016+-- License:    BSD3+-- Maintainer: Ole Krüger <ole@vprsm.de>+module Database.PostgreSQL.Store.OIDs (+	OIDQ,++	bool,+	int2,+	int4,+	int8,+	float4,+	float8,+	numeric,+	char,+	varchar,+	text,+	bytea,+	timestamp,+	timestamptz+) where++import           Language.Haskell.TH+import qualified Database.PostgreSQL.LibPQ as P++class GenOID a where+	genOID :: Integer -> Q a++instance GenOID Exp where+	genOID oid = [e| P.Oid $(litE (IntegerL oid)) |]++instance GenOID Pat where+	genOID oid = [p| P.Oid $(pure (LitP (IntegerL oid))) |]++-- | A type which can be coerced into @Q Exp@ or @Q Pat@.+type OIDQ = forall a . GenOID a => Q a++-- | Boolean+bool :: OIDQ+bool = genOID 16++-- | 16-bit integer+int2 :: OIDQ+int2 = genOID 21++-- | 32-bit integer+int4 :: OIDQ+int4 = genOID 23++-- | 64-bit integer+int8 :: OIDQ+int8 = genOID 20++-- | Single-precision floating-point number+float4 :: OIDQ+float4 = genOID 700++-- | Double-precision floating-point number+float8 :: OIDQ+float8 = genOID 701++-- | Arbitrary precision number+numeric :: OIDQ+numeric = genOID 1700++-- | Fixed-length string+char :: OIDQ+char    = genOID 1042++-- | Variable-length string+varchar :: OIDQ+varchar = genOID 1043++-- | Unlimited variable-length string+text :: OIDQ+text = genOID 25++-- | Byte array+bytea :: OIDQ+bytea = genOID 17++-- | Timestamp without timezone+timestamp :: OIDQ+timestamp = genOID 1114++-- | Timestamp with timezone+timestamptz :: OIDQ+timestamptz = genOID 1184

@@ -1,4 +1,6 @@-{-# LANGUAGE OverloadedStrings, TemplateHaskell, BangPatterns #-}+{-# LANGUAGE QuasiQuotes, TemplateHaskell, BangPatterns,+             GeneralizedNewtypeDeriving, MultiParamTypeClasses, FunctionalDependencies,+             FlexibleInstances, FlexibleContexts, TypeFamilies #-}  -- | -- Module:     Database.PostgreSQL.Store.Query@@ -6,62 +8,59 @@ -- License:    BSD3 -- Maintainer: Ole Krüger <ole@vprsm.de> module Database.PostgreSQL.Store.Query (-	-- * Tables-	TableDescription (..),-	DescribableTable (..),--	-- * Querying+	-- * Query 	Query (..),-	pgsq+	SelectorElement (..),+	QueryTable (..),+	pgsq,+	pgss,++	-- * Helpers+	quoteIdentifier,++	-- * Query builder+	QueryCode,+	QueryBuildable,+	QueryBuilder,+	runQueryBuilder,+	writeCode,+	writeStringCode,+	writeIdentifier,+	writeAbsIdentifier,+	writeParam,+	writeColumn,+	intercalateBuilder ) where  import           Language.Haskell.TH import           Language.Haskell.TH.Quote  import           Control.Applicative-import           Control.Monad.Trans.Class-import           Control.Monad.Trans.State+import           Control.Monad.State.Strict -import           Data.Char+import           Data.List+import           Data.Proxy+import           Data.Monoid import           Data.String-import           Data.Typeable-import           Data.Attoparsec.Text-import qualified Data.Text as T-import qualified Data.Text.Encoding as T+import qualified Data.Text       as T import qualified Data.ByteString as B -import           Database.PostgreSQL.Store.Columns---- | Description of a table type-data TableDescription = TableDescription {-	-- | Table name-	tableName :: String,--	-- | Identifier column name-	tableIdentifier :: String-} deriving (Show, Eq, Ord)---- | Attach meta data to a table type-class DescribableTable a where-	-- | Describe the table.-	describeTable :: Proxy a -> TableDescription-	describeTable proxy =-		TableDescription {-			tableName = describeTableName proxy,-			tableIdentifier = describeTableIdentifier proxy-		}+import           Data.Char+import           Data.Attoparsec.Text -	-- | Describe table name.-	describeTableName :: Proxy a -> String-	describeTableName proxy =-		tableName (describeTable proxy)+import           Database.PostgreSQL.Store.Columns -	-- | Describe table identifier.-	describeTableIdentifier :: Proxy a -> String-	describeTableIdentifier proxy =-		tableIdentifier (describeTable proxy)+-- | Properly quote an identifier.+quoteIdentifier :: String -> String+quoteIdentifier name =+	'"' : stripQuotes name ++ "\""+	where+		stripQuotes []         = []+		stripQuotes ('"' : xs) = '"' : '"' : stripQuotes xs+		stripQuotes (x : xs)   = x : stripQuotes xs --- | Query including statement and parameters.+-- | Query including statement and parameters+-- -- Use the 'pgsq' quasi-quoter to conveniently create queries. data Query = Query { 	-- | Statement@@ -71,72 +70,248 @@ 	queryParams :: ![Value] } deriving (Show, Eq, Ord) --- | Generate a 'Query' from a SQL statement.+-- | @SELECT@ expression+data SelectorElement+	= SelectorField String+	  -- ^ Select a field. The field nme will be quoted and properly escaped.+	| SelectorSpecial String+	  -- ^ Select a special expression. The expression will be inlined as is.+	deriving (Show, Eq, Ord)++-- | A type which implements this class can be used as a table in a quasi-quoted query.+--   'mkTable' can implement this for you.+class QueryTable a where+	-- | Unquoted name of the table+	tableName :: Proxy a -> String++	-- | Unquoted name of the ID field+	tableIDName :: Proxy a -> String++	-- | Selectors needed to retrieve all fields necessary to construct the type - think @SELECT@.+	tableSelectors :: Proxy a -> [SelectorElement]++-- | Generate the quoted identifier for a table.+makeTableIdentifier :: (QueryTable a, IsString b) => Proxy a -> b+makeTableIdentifier proxy =+	fromString (quoteIdentifier (tableName proxy))++-- | Generate the quoted identifier for table's id column.+makeTableIDIdentifier :: (QueryTable a, IsString b) => Proxy a -> b+makeTableIDIdentifier proxy =+	fromString (quoteIdentifier (tableName proxy) +++	            "." +++	            quoteIdentifier (tableIDName proxy))++-- | Generate the list of expression used as selector.+makeTableSelectors :: (QueryTable a, IsString b) => Proxy a -> b+makeTableSelectors proxy =+	fromString (intercalate ", " (map makeElement (tableSelectors proxy)))+	where+		makeElement (SelectorField name) =+			quoteIdentifier (tableName proxy) ++ "." ++ quoteIdentifier name+		makeElement (SelectorSpecial expr) =+			expr++-- | Query segment+data Segment+	= SSelector String+	| STable String+	| SVariable String+	| SIdentifier String+	| SQuote Char String+	| SOther String++-- | Name+name :: Parser String+name =+	(:) <$> (letter <|> char '_') <*> many (satisfy isAlphaNum <|> char '_')++-- | Type name+typeName :: Parser String+typeName =+	(:) <$> satisfy isUpper <*> many (satisfy isAlphaNum <|> char '_')++-- | Qualified type name+qualifiedTypeName :: Parser String+qualifiedTypeName = do+	intercalate "." <$> sepBy1 typeName (char '.')++-- | Quote+quote :: Char -> Parser Segment+quote delim = do+	char delim+	cnt <- concat <$> many (choice [escapedDelim, notDelim])+	char delim+	pure (SQuote delim cnt)+	where+		escapedDelim = (\ a b -> [a, b]) <$> char '\\' <*> char delim+		notDelim = (: []) <$> notChar delim++-- | Segments+segments :: Parser [Segment]+segments =+	many (choice [quote '"',+	              quote '\'',+	              char '#' >> SSelector <$> qualifiedTypeName,+	              char '@' >> STable <$> qualifiedTypeName,+	              char '&' >> SIdentifier <$> qualifiedTypeName,+	              char '$' >> SVariable <$> name,+	              SOther "#" <$ char '#',+	              SOther "@" <$ char '@',+	              SOther "&" <$ char '&',+	              SOther "$" <$ char '$',+	              SOther <$> some (satisfy (notInClass "\"'#@&$"))])++-- | Reduce segments in order to resolve names and collect query parameters.+reduceSegment :: Segment -> QueryBuilder [Q Exp] (Q Exp)+reduceSegment seg =+	case seg of+		SOther str ->+			writeStringCode str++		SQuote delim cnt ->+			writeStringCode (delim : cnt ++ [delim])++		SVariable varName -> writeParam $ do+			mbName <- lookupValueName varName+			case mbName of+				Just name -> [e| pack $(varE name) |]+				Nothing   -> fail ("'" ++ varName ++ "' does not refer to anything")++		STable tableName -> writeCode $ do+			mbName <- lookupTypeName tableName+			case mbName of+				Just table -> [e| makeTableIdentifier (Proxy :: Proxy $(conT table)) |]+				Nothing    -> fail ("'" ++ tableName ++ "' does not refer to anything")++		SSelector tableName -> writeCode $ do+			mbName <- lookupTypeName tableName+			case mbName of+				Just table -> [e| makeTableSelectors (Proxy :: Proxy $(conT table)) |]+				Nothing    -> fail ("'" ++ tableName ++ "' does not refer to anything")++		SIdentifier tableName -> writeCode $ do+			mbName <- lookupTypeName tableName+			case mbName of+				Just table -> [e| makeTableIDIdentifier (Proxy :: Proxy $(conT table)) |]+				Nothing    -> fail ("'" ++ tableName ++ "' does not refer to anything")++-- | Parse quasi-quoted query.+parseStoreQueryE :: String -> Q Exp+parseStoreQueryE code = do+	case parseOnly (segments <* endOfInput) (T.pack code) of+		Left msg ->+			fail msg++		Right xs -> do+			runQueryBuilder (mapM_ reduceSegment xs)++-- | This quasi-quoter allows you to generate instances of 'Query'. It lets you write SQL with some+-- small enhancements. 'pgsq' heavily relies on 'QueryTable' which can be implemented by 'mkTable'+-- for a type of your choice. ----- = Table and column names+-- Some syntax definitions that might be useful later on: ----- All plain identifiers will be treated as Haskell names. They are going to be resolved to their--- fully-qualified and quoted version. Beware, the use of names which don't refer to a table type--- or field will likely result in unknown table or column errors. The associated table name of a--- type is retrieved using 'describeTableName'.--- If you don't want a name to be resolved use a quoted identifier.+-- > TypeName          ::= UpperAlpha {AlphaNumeric | '_'}+-- > Name              ::= (Alpha | '_') {AlphaNumeric | '_'}+-- > QualifiedTypeName ::= {TypeName '.'} TypeName ----- Example:+-- @Alpha@ includes all alphabetical characters; @UpperAlpha@ includes all upper-case alphabetical+-- characters; @AlphaNumeric@ includes all alpha-numeric characters. ----- @--- {-\# LANGUAGE QuasiQuotes \#-}--- module MyModule where+-- = Embed values+-- You can embed values whose types implement 'Column'. ----- ...+-- > ValueExp ::= '$' Name ----- data Table = Table { myField :: Int }--- 'mkTable' ''Table []+-- > magicNumber :: Int+-- > magicNumber = 1337+-- >+-- > myQuery :: Query+-- > myQuery =+-- >     [pgsq| SELECT * FROM table t WHERE t.column1 > $magicNumber AND t.column2 < $otherNumber |]+-- >     where otherNumber = magicNumber * 2 ----- myQuery :: 'Query'--- myQuery = ['pgsq'| SELECT * FROM Table WHERE myField > 1337 |]--- @+-- @$magicNumber@ and @$otherNumber@ are references to values @magicNumber@ and @otherNumber@. ----- The SQL statement associated with @myQuery@ will be:+-- The quasi-quoter will generate a 'Query' expression similar to the following. ----- > SELECT * FROM "MyModule.Table" WHERE "MyModule.myField" > 1337+-- > Query "SELECT * FROM table t WHERE t.column1 > $1 AND t.column2 < $2"+-- >       [pack magicNumber, pack otherNumber] ----- = Variables+-- = Table names+-- Types that implement 'QueryTable' associate a table name with themselves. Since the table name is+-- not always known to the user, one can insert it dynamically. ----- You can use reference variables with @$myVariable@. The variable's type has to be an instance of--- 'Column', otherwise it cannot be attached as query parameter.+-- > TableNameExp ::= '@' QualifiedTypeName ----- Example:+-- The @\@@-operators is also an alias for the function @ABS@. If you have an expression that+-- triggers the quasi-quoter such as @\@A@, but you would like to use the @ABS@ functionality, then+-- simply reformat your expression to @\@(A)@ or @\@\"A\"@ or @ABS(A)@. ----- @--- magicNumber :: Int--- magicNumber = 1337+-- > instance QueryTable YourType where+-- >     tableName _ = "YourTable"+-- >+-- > myQuery :: Query+-- > myQuery =+-- >     [pgsq| SELECT * FROM @Table WHERE @Table.column = 1337 |] ----- myQuery :: 'Query'--- myQuery = ['pgsq'| SELECT * FROM Table WHERE myField > $magicNumber |]--- @+-- The table name will be inlined which results in the following. ----- = Row identifiers+-- > Query "SELECT * FROM \"YourTable\" WHERE \"YourTable\".column = 1337" [] ----- Each instance of @('Table' a) => 'Row' a@, @('Table' a) => 'Reference' a@ and each row of the actual table inside the database--- has an identifier value. These identifiers are used to reference specific rows. The identifier--- column is exposed via the @&MyTable@ pattern. Identifier field names are resolved using--- 'describeTableIdentifier'.+-- = Identifier column names+-- Each instance of 'QueryTable' also provides the name of the identifier column. Using this column+-- name you can identify specific rows of a certain table. ----- Example:+-- > TableIdentExp ::= '&' TypeName ----- @--- ['pgsq'| SELECT *---        FROM TableA, TableB---        WHERE refToB = &TableB |]--- @+-- @&@ is also the operator for bitwise-AND. To resolve the ambiguity for expressions like @A&B@,+-- simply reformat it to @A & B@ or @A&(B)@ or @A&\"B\"@. ----- Note @refToB@ is a field of @TableA@.--- In different circumstances one would write such query as follows.+-- > instance QueryTable YourType where+-- >     tableName _   = "YourTable"+-- >     tableIDName _ = "id"+-- >+-- > listIDs :: Query+-- > listIDs =+-- >     [pgsq| SELECT &YourType FROM @YourType |] ----- > SELECT *--- > FROM TableA a, Table b--- > WHERE a.refToB = b.id+-- @listIDs@ is now a query which lists the IDs of each row. This is especially useful in+-- combination with 'Reference'. --+-- > fetchIDs :: Errand [Reference YourType]+-- > fetchIDs =+-- >     query [pgsq| SELECT &YourType FROM @YourType |]+--+-- Note, just like @\@@, the operator @&@ is reserved. Although @A&B@ is a valid SQL expression, it+-- will trigger the quasi-quoter. To avoid this, you reform your expression to @A & B@ or @A&(B)@.+--+-- = Selectors+-- 'mkTable' will automatically implement 'Result' and 'QueryTable' for you. This allows you to make+-- use of the selector expander.+--+-- > SelectorExp ::= '#' QualifiedTypeName+--+-- @#@ is also the operator for bitwise-XOR. To resolve the ambiguity for expressions like @A#B@,+-- simply reformat it to @A # B@ or @A#(B)@ or @A#\"B\"@.+--+-- > data Actor = Actor {+-- >     actorName :: String,+-- >     actorAge  :: Word+-- > } deriving (Show, Eq, Ord)+-- >+-- > mkTable ''Actor []+-- >+-- > fetchOldActors :: Errand [Actor]+-- > fetchOldActors =+-- >     query [pgsq| SELECT #Actor FROM @Actor a WHERE a.actorAge >= $oldAge |]+-- >     where oldAge = 70+--+-- @#Actor@ will expand to a list of columns that are necessary to construct an instance of @Actor@.+-- In this case it is equivalent to+--+-- > @Actor.actorName, @Actor.actorAge pgsq :: QuasiQuoter pgsq = 	QuasiQuoter {@@ -146,205 +321,127 @@ 		quoteDec  = const (fail "Cannot use 'pgsq' in declaration") 	} --- | List of relevant SQL keywords-reservedSQLKeywords :: [T.Text]-reservedSQLKeywords =-	["ABS", "ABSOLUTE", "ACTION", "ADD", "ALL", "ALLOCATE", "ALTER", "ANALYSE", "ANALYZE", "AND",-	 "ANY", "ARE", "ARRAY", "ARRAY_AGG", "ARRAY_MAX_CARDINALITY", "AS", "ASC", "ASENSITIVE",-	 "ASSERTION", "ASYMMETRIC", "AT", "ATOMIC", "AUTHORIZATION", "AVG", "BEGIN", "BEGIN_FRAME",-	 "BEGIN_PARTITION", "BETWEEN", "BIGINT", "BINARY", "BIT", "BIT_LENGTH", "BLOB", "BOOLEAN",-	 "BOTH", "BY", "CALL", "CALLED", "CARDINALITY", "CASCADE", "CASCADED", "CASE", "CAST", "CATALOG",-	 "CEIL", "CEILING", "CHAR", "CHARACTER", "CHARACTER_LENGTH", "CHAR_LENGTH", "CHECK", "CLOB",-	 "CLOSE", "COALESCE", "COLLATE", "COLLATION", "COLLECT", "COLUMN", "COMMIT", "CONCURRENTLY",-	 "CONDITION", "CONNECT", "CONNECTION", "CONSTRAINT", "CONSTRAINTS", "CONTAINS", "CONTINUE",-	 "CONVERT", "CORR", "CORRESPONDING", "COUNT", "COVAR_POP", "COVAR_SAMP", "CREATE", "CROSS",-	 "CUBE", "CUME_DIST", "CURRENT", "CURRENT_CATALOG", "CURRENT_DATE",-	 "CURRENT_DEFAULT_TRANSFORM_GROUP", "CURRENT_PATH", "CURRENT_ROLE",-	 "CURRENT_ROW", "CURRENT_SCHEMA", "CURRENT_TIME", "CURRENT_TIMESTAMP",-	 "CURRENT_TRANSFORM_GROUP_FOR_TYPE", "CURRENT_USER", "CURSOR", "CYCLE", "DATALINK", "DATE",-	 "DAY", "DEALLOCATE", "DEC", "DECIMAL", "DECLARE", "DEFAULT", "DEFERRABLE", "DEFERRED", "DELETE",-	 "DENSE_RANK", "DEREF", "DESC", "DESCRIBE", "DESCRIPTOR", "DETERMINISTIC", "DIAGNOSTICS",-	 "DISCONNECT", "DISTINCT", "DLNEWCOPY", "DLPREVIOUSCOPY", "DLURLCOMPLETE", "DLURLCOMPLETEONLY",-	 "DLURLCOMPLETEWRITE", "DLURLPATH", "DLURLPATHONLY", "DLURLPATHWRITE", "DLURLSCHEME",-	 "DLURLSERVER", "DLVALUE", "DO", "DOMAIN", "DOUBLE", "DROP", "DYNAMIC", "EACH", "ELEMENT",-	 "ELSE", "END", "END", "END_FRAME", "END_PARTITION", "EQUALS", "ESCAPE", "EVERY", "EXCEPT",-	 "EXCEPTION", "EXEC", "EXECUTE", "EXISTS", "EXP", "EXTERNAL", "EXTRACT", "FALSE", "FETCH",-	 "FILTER", "FIRST", "FIRST_VALUE", "FLOAT", "FLOOR", "FOR", "FOREIGN", "FOUND", "FRAME_ROW",-	 "FREE", "FREEZE", "FROM", "FULL", "FUNCTION", "FUSION", "GET", "GLOBAL", "GO", "GOTO", "GRANT",-	 "GROUP", "GROUPING", "GROUPS", "HAVING", "HOLD", "HOUR", "IDENTITY", "ILIKE", "IMMEDIATE",-	 "IMPORT", "IN", "INDICATOR", "INITIALLY", "INNER", "INOUT", "INPUT", "INSENSITIVE", "INSERT",-	 "INT", "INTEGER", "INTERSECT", "INTERSECTION", "INTERVAL", "INTO", "IS", "ISNULL", "ISOLATION",-	 "JOIN", "KEY", "LAG", "LANGUAGE", "LARGE", "LAST", "LAST_VALUE", "LATERAL", "LEAD", "LEADING",-	 "LEFT", "LEVEL", "LIKE", "LIKE_REGEX", "LIMIT", "LN", "LOCAL", "LOCALTIME", "LOCALTIMESTAMP",-	 "LOWER", "MATCH", "MAX", "MAX_CARDINALITY", "MEMBER", "MERGE", "METHOD", "MIN", "MINUTE", "MOD",-	 "MODIFIES", "MODULE", "MONTH", "MULTISET", "NAMES", "NATIONAL", "NATURAL", "NCHAR", "NCLOB",-	 "NEW", "NEXT", "NO", "NONE", "NORMALIZE", "NOT", "NOTNULL", "NTH_VALUE", "NTILE", "NULL",-	 "NULLIF", "NUMERIC", "OCCURRENCES_REGEX", "OCTET_LENGTH", "OF", "OFFSET", "OLD", "ON", "ONLY",-	 "OPEN", "OPTION", "OR", "ORDER", "OUT", "OUTER", "OUTPUT", "OVER", "OVERLAPS", "OVERLAY", "PAD",-	 "PARAMETER", "PARTIAL", "PARTITION", "PERCENT", "PERCENTILE_CONT", "PERCENTILE_DISC",-	 "PERCENT_RANK", "PERIOD", "PLACING", "PORTION", "POSITION", "POSITION_REGEX", "POWER",-	 "PRECEDES", "PRECISION", "PREPARE", "PRESERVE", "PRIMARY", "PRIOR", "PRIVILEGES", "PROCEDURE",-	 "PUBLIC", "RANGE", "RANK", "READ", "READS", "REAL", "RECURSIVE", "REF", "REFERENCES",-	 "REFERENCING", "REGR_AVGX", "REGR_AVGY", "REGR_COUNT", "REGR_INTERCEPT", "REGR_R2",-	 "REGR_SLOPE", "REGR_SXX", "REGR_SXY", "REGR_SYY", "RELATIVE", "RELEASE", "RESTRICT", "RESULT",-	 "RETURN", "RETURNING", "RETURNS", "REVOKE", "RIGHT", "ROLLBACK", "ROLLUP", "ROW", "ROWS",-	 "ROW_NUMBER", "SAVEPOINT", "SCHEMA", "SCOPE", "SCROLL", "SEARCH", "SECOND", "SECTION", "SELECT",-	 "SENSITIVE", "SESSION", "SESSION_USER", "SET", "SIMILAR", "SIZE", "SMALLINT", "SOME", "SPACE",-	 "SPECIFIC", "SPECIFICTYPE", "SQL", "SQLCODE", "SQLERROR", "SQLEXCEPTION", "SQLSTATE",-	 "SQLWARNING", "SQRT", "START", "STATIC", "STDDEV_POP", "STDDEV_SAMP", "SUBMULTISET",-	 "SUBSTRING", "SUBSTRING_REGEX", "SUCCEEDS", "SUM", "SYMMETRIC", "SYSTEM", "SYSTEM_TIME",-	 "SYSTEM_USER", "TABLE", "TABLESAMPLE", "TEMPORARY", "THEN", "TIME", "TIMESTAMP",-	 "TIMEZONE_HOUR", "TIMEZONE_MINUTE", "TO", "TRAILING", "TRANSACTION", "TRANSLATE",-	 "TRANSLATE_REGEX", "TRANSLATION", "TREAT", "TRIGGER", "TRIM", "TRIM_ARRAY", "TRUE", "TRUNCATE",-	 "UESCAPE", "UNION", "UNIQUE", "UNKNOWN", "UNNEST", "UPDATE", "UPPER", "USAGE", "USER", "USING",-	 "VALUE", "VALUES", "VALUE_OF", "VARBINARY", "VARCHAR", "VARIADIC", "VARYING", "VAR_POP",-	 "VAR_SAMP", "VERBOSE", "VERSIONING", "VIEW", "WHEN", "WHENEVER", "WHERE", "WIDTH_BUCKET",-	 "WINDOW", "WITH", "WITHIN", "WITHOUT", "WORK", "WRITE", "XML", "XMLAGG", "XMLATTRIBUTES",-	 "XMLBINARY", "XMLCAST", "XMLCOMMENT", "XMLCONCAT", "XMLDOCUMENT", "XMLELEMENT", "XMLEXISTS",-	 "XMLFOREST", "XMLITERATE", "XMLNAMESPACES", "XMLPARSE", "XMLPI", "XMLQUERY", "XMLSERIALIZE",-	 "XMLTABLE", "XMLTEXT", "XMLVALIDATE", "YEAR", "ZONE"]+-- | Parse quasi-quoted query but return only statement.+parseStoreStatementE :: String -> Q Exp+parseStoreStatementE code = do+	case parseOnly (segments <* endOfInput) (T.pack code) of+		Left msg ->+			fail (show msg) --- | Query segment-data Segment-	= Keyword T.Text-	| PossibleName T.Text-	| Variable T.Text-	| Identifier T.Text-	| Quote Char T.Text-	| Other Char+		Right xs -> do+			[e| mconcat $(listE (runQueryBuilder_ (mapM_ reduceSegment xs))) |] --- | SQL keyword-keyword :: Parser Segment-keyword =-	Keyword <$> choice (asciiCI <$> reservedSQLKeywords)+-- | Just like 'pgsq' but only produces the statement associated with the query. Referenced+-- values are not inlined, they are simply dismissed.+pgss :: QuasiQuoter+pgss =+	QuasiQuoter {+		quoteExp  = parseStoreStatementE,+		quotePat  = const (fail "Cannot use 'pgss' in pattern"),+		quoteType = const (fail "Cannot use 'pgss' in type"),+		quoteDec  = const (fail "Cannot use 'pgss' in declaration")+	} --- | Alpha numeric character-alphaNum :: Parser Char-alphaNum = satisfy isAlphaNum+-- | Internal state for every builder+data BuilderState s p = BuilderState s Word [p] --- | Underscore-underscore :: Parser Char-underscore = char '_'+-- |+class QueryCode s where+	type Code s --- | Dot-dot :: Parser Char-dot = char '.'+	appendCode :: s -> Code s -> s --- | Name-name :: Parser T.Text-name =-	bake <$> (letter <|> underscore) <*> many (alphaNum <|> underscore <|> dot)-	where-		bake h t = T.pack (h : t)+	appendStringCode :: s -> String -> s --- | Possible name-possibleName :: Parser Segment-possibleName =-	PossibleName <$> name+instance QueryCode B.ByteString where+	type Code B.ByteString = B.ByteString --- | Variable-variable :: Parser Segment-variable = do-	char '$'-	Variable <$> name+	appendCode = B.append --- | Identifier-identifier :: Parser Segment-identifier = do-	char '&'-	Identifier <$> name+	appendStringCode bs str = bs <> fromString str --- | Quote-quote :: Char -> Parser Segment-quote delim = do-	char delim-	cnt <- scan (False, T.empty) scanner-	char delim-	pure (Quote delim cnt)-	where-		scanner (False, _) chr | chr == delim = Nothing-		scanner (esc, cnt) chr = Just (not esc && chr == '\\', cnt `T.snoc` chr)+instance QueryCode [Q Exp] where+	type Code [Q Exp] = Q Exp --- | Segments-segments :: Parser [Segment]-segments =-	many (choice [-		quote '"',-		quote '\'',-		variable,-		identifier,-		keyword,-		possibleName,-		Other <$> anyChar-	])+	appendCode segments exp = segments ++ [exp] --- | Turn "Text" into a UTF-8-encoded "ByteString" expression.-textE :: T.Text -> StateT (Int, [Exp]) Q Exp-textE txt =-	lift (stringE (T.unpack txt))+	appendStringCode segments str = appendCode segments [e| fromString $(stringE str) |] --- | Reduce segments in order to resolve names and collect query parameters.-reduceSegment :: Segment -> StateT (Int, [Exp]) Q Exp-reduceSegment seg =-	case seg of-		Keyword kw ->-			textE kw+instance QueryCode String where+	type Code String = String -		Other o ->-			lift (stringE [o])+	appendCode segments code = segments ++ code -		Quote delim cnt ->-			lift (stringE (delim : T.unpack cnt ++ [delim]))+	appendStringCode = appendCode -		Variable varName -> do-			mbName <- lift (lookupValueName (T.unpack varName))-			case mbName of-				Just name -> do-					-- Generate the pack expression-					lit <- lift [e| pack $(varE name) |]+-- | Can build @o@ using @s@ and @[p]@.+class QueryBuildable s p o | s p -> o where+	buildQuery :: s -> [p] -> o -					-- Register parameter-					(numParams, params) <- get-					put (numParams + 1, params ++ [lit])+instance QueryBuildable B.ByteString Value Query where+	buildQuery = Query -					lift (stringE ("$" ++ show (numParams + 1)))+instance QueryBuildable String (Q Exp) (Q Exp) where+	buildQuery code params =+		[e| Query (fromString $(stringE code)) $(listE params) |] -				Nothing ->-					lift (fail ("\ESC[34m" ++ T.unpack varName ++-					            "\ESC[0m does not refer to anything"))+instance QueryBuildable [Q Exp] (Q Exp) (Q Exp) where+	buildQuery codeSegments params =+		[e| Query (B.concat $(listE codeSegments)) $(listE params) |] -		PossibleName posName -> do-			let strName = T.unpack posName-			mbName <- lift ((,) <$> lookupTypeName strName <*> lookupValueName strName)-			case mbName of-				(Just typName, _) ->-					lift [e| "\"" ++ describeTableName (Proxy :: Proxy $(conT typName)) ++ "\"" |]+-- | Query builder+type QueryBuilder s p = State (BuilderState s p) () -				(_, Just varName) ->-					lift (stringE (sanitizeName' varName))+-- | Run query builder.+runQueryBuilder :: (QueryBuildable s p o, Monoid s) => QueryBuilder s p -> o+runQueryBuilder builder =+	buildQuery code params+	where+		BuilderState code _ params = execState builder (BuilderState mempty 1 []) -				_ -> textE posName+-- | Run query builder, return only the statement.+runQueryBuilder_ :: (Monoid s) => QueryBuilder s p -> s+runQueryBuilder_ builder =+	code+	where+		BuilderState code _ _ = execState builder (BuilderState mempty 1 []) -		Identifier idnName -> do-			mbName <- lift (lookupTypeName (T.unpack idnName))-			case mbName of-				Just name ->-					lift [e| "\"" ++ describeTableIdentifier (Proxy :: Proxy $(conT name)) ++ "\"" |]+-- | Write code.+writeCode :: (QueryCode s) => Code s -> QueryBuilder s p+writeCode code =+	modify $ \ (BuilderState stmt idx params) ->+		BuilderState (appendCode stmt code) idx params -				Nothing ->-					lift (fail ("\ESC[34m" ++ T.unpack idnName ++-					            "\ESC[0m does not refer to anything"))+-- | Write string code.+writeStringCode :: (QueryCode s) => String -> QueryBuilder s p+writeStringCode code =+	modify $ \ (BuilderState stmt idx params) ->+		BuilderState (appendStringCode stmt code) idx params --- | Parse quasi-quoted PG Store Query.-parseStoreQueryE :: String -> Q Exp-parseStoreQueryE code = do-	case parseOnly segments (fromString code) of-		Left msg ->-			fail msg+-- | Add an identifier.+writeIdentifier :: (QueryCode s) => String -> QueryBuilder s p+writeIdentifier name =+	writeStringCode (quoteIdentifier name) -		Right xs -> do-			(parts, (_, params)) <- runStateT (mapM reduceSegment xs) (0, [])-			[e| Query {-			        queryStatement = T.encodeUtf8 (T.pack (concat $(pure (ListE parts)))),-			        queryParams    = $(pure (ListE params))-			    } |]+-- | Add an absolute identifier.+writeAbsIdentifier :: (QueryCode s) => String -> String -> QueryBuilder s p+writeAbsIdentifier ns name = do+	writeIdentifier ns+	writeStringCode "."+	writeIdentifier name++-- | Embed a parameter.+writeParam :: (QueryCode s) => p -> QueryBuilder s p+writeParam param = do+	modify $ \ (BuilderState code idx params) ->+		BuilderState (appendStringCode code ("$" ++ show idx)) (idx + 1) (params ++ [param])++-- | Embed a value parameter.+writeColumn :: (Column p, QueryCode s) => p -> QueryBuilder s Value+writeColumn param =+	writeParam (pack param)++-- | Do something between other builders.+intercalateBuilder :: QueryBuilder s p -> [QueryBuilder s p] -> QueryBuilder s p+intercalateBuilder x xs =+	sequence_ (intersperse x xs)

@@ -1,192 +1,82 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+ -- | -- Module:     Database.PostgreSQL.Store.Result -- Copyright:  (c) Ole Krüger 2015-2016 -- License:    BSD3 -- Maintainer: Ole Krüger <ole@vprsm.de> module Database.PostgreSQL.Store.Result (-	-- *+	-- * Result processor 	ResultError (..), 	ResultProcessor,-	ColumnInfo,-	runResultProcessor,-	columnNumber,-	columnType,-	columnFormat,-	columnInfo,-	foreachRow,-	cellValue,-	unpackCellValue,+	processResult,+	processOneResult, -	-- * Result-	Result (..),-	RawRow (..)+	skipColumn,+	unpackColumn ) where  import           Control.Monad-import           Control.Monad.Trans.Class-import           Control.Monad.Trans.Reader-import           Control.Monad.Trans.Except--import           Data.List-import           Data.Typeable-import qualified Data.ByteString           as B+import           Control.Monad.Trans+import           Control.Monad.Reader+import           Control.Monad.State.Strict+import           Control.Monad.Except  import qualified Database.PostgreSQL.LibPQ as P import           Database.PostgreSQL.Store.Columns  -- | Error that occured during result processing data ResultError-	= ColumnMissing B.ByteString-	| ValueError P.Row P.Column P.Oid P.Format ColumnDescription+	= TooFewColumnsError P.Column+	  -- ^ Occurs when you're trying to access a column that does not exist.+	| UnpackError P.Row P.Column P.Oid P.Format+	  -- ^ The value at a given row and column could not be unpacked. 	deriving (Show, Eq)  -- | Result processor-type ResultProcessor = ReaderT P.Result (ExceptT ResultError IO)---- | Column information-type ColumnInfo = (P.Column, P.Oid, P.Format)---- | Process the result.-runResultProcessor :: P.Result -> ResultProcessor a -> ExceptT ResultError IO a-runResultProcessor = flip runReaderT---- | Get the number of columns.-numColumns :: ResultProcessor P.Column-numColumns = do-	result <- ask-	lift (lift (P.nfields result))---- | Get the column number for a column name.-columnNumber :: B.ByteString -> ResultProcessor P.Column-columnNumber name = do-	result <- ask-	lift (ExceptT (maybe (Left (ColumnMissing name)) pure <$> P.fnumber result name))---- | Get the type of a column.-columnType :: P.Column -> ResultProcessor P.Oid-columnType col = do-	result <- ask-	lift (lift (P.ftype result col))---- | Get the format of a column.-columnFormat :: P.Column -> ResultProcessor P.Format-columnFormat col = do-	result <- ask-	lift (lift (P.fformat result col))---- | Get information about a column.-columnInfo :: B.ByteString -> ResultProcessor ColumnInfo-columnInfo name = do-	col <- columnNumber name-	(,,) col <$> columnType col <*> columnFormat col---- | Do something for each row.-foreachRow :: (P.Row -> ResultProcessor a) -> ResultProcessor [a]-foreachRow rowProcessor = do-	result <- ask-	numRows <- lift (lift (P.ntuples result))-	mapM rowProcessor [0 .. numRows - 1]---- | Get cell value.-cellValue :: P.Row -> ColumnInfo -> ResultProcessor Value-cellValue row (col, oid, fmt) = do-	result <- ask-	value <- lift (lift (P.getvalue' result row col))--	case value of-		Just dat -> pure (Value oid dat fmt)-		Nothing  -> pure NullValue---- | Get cell value.-cellValue' :: P.Row -> P.Column -> ResultProcessor Value-cellValue' row col = do-	result <- ask-	(oid, fmt, value) <- lift (lift ((,,) <$> P.ftype result col-	                                      <*> P.fformat result col-	                                      <*> P.getvalue' result row col))--	case value of-		Just dat -> pure (Value oid dat fmt)-		Nothing  -> pure NullValue----- | Unpack cell value.-unpackCellValue :: (Column a) => P.Row -> ColumnInfo -> ResultProcessor a-unpackCellValue row info =-	withProxy Proxy-	where-		withProxy :: (Column a) => Proxy a -> ResultProcessor a-		withProxy proxy = do-			value <- cellValue row info-			lift (ExceptT (make (describeColumn proxy) (unpack value)))--		(col, oid, fmt) = info--		valueError desc =-			pure (Left (ValueError row col oid fmt desc))--		make desc =-			maybe (valueError desc) (pure . pure)---- | Result row-class Result a where-	-- | Extract rows from the given result.-	resultProcessor :: ResultProcessor [a]+newtype ResultProcessor a =+	ResultProcessor (StateT P.Column (ReaderT (P.Result, P.Row, P.Column) (ExceptT ResultError IO)) a)+	deriving (Functor, Applicative, Monad, MonadIO, MonadError ResultError) -instance Result () where-	resultProcessor = foreachRow (const (pure ()))+-- | Move cursor to the next column.+skipColumn :: ResultProcessor ()+skipColumn =+	ResultProcessor (modify (+ 1)) -instance (Result a, Result b) => Result (a, b) where-	resultProcessor =-		zip <$> resultProcessor-		    <*> resultProcessor+-- | Unpack the current column and move the cursor to the next column.+unpackColumn :: (Column a) => ResultProcessor a+unpackColumn = do+	-- Gather information+	col <- ResultProcessor get+	(res, row, numCol) <- ResultProcessor ask -instance (Result a, Result b, Result c) => Result (a, b, c) where-	resultProcessor =-		zip3 <$> resultProcessor-		     <*> resultProcessor-		     <*> resultProcessor+	-- Make sure we're not trying to unpack a non-existing column+	when (col >= numCol) (throwError (TooFewColumnsError numCol)) -instance (Result a, Result b, Result c, Result d) => Result (a, b, c, d) where-	resultProcessor =-		zip4 <$> resultProcessor-		     <*> resultProcessor-		     <*> resultProcessor-		     <*> resultProcessor+	-- Retrieve column-specific information+	(typ, mbData) <- liftIO $+		(,) <$> P.ftype res col <*> P.getvalue' res row col -instance (Result a, Result b, Result c, Result d, Result e) => Result (a, b, c, d, e) where-	resultProcessor =-		zip5 <$> resultProcessor-		     <*> resultProcessor-		     <*> resultProcessor-		     <*> resultProcessor-		     <*> resultProcessor+	-- Try to unpack the value+	case unpack (maybe NullValue (Value typ) mbData) of+		Just ret -> ResultProcessor (put (col + 1) >> pure ret)+		Nothing  -> throwError (UnpackError row col typ P.Text) -instance (Result a, Result b, Result c, Result d, Result e, Result f) => Result (a, b, c, d, e, f) where-	resultProcessor =-		zip6 <$> resultProcessor-		     <*> resultProcessor-		     <*> resultProcessor-		     <*> resultProcessor-		     <*> resultProcessor-		     <*> resultProcessor+-- | Process the entire result set.+processResult :: P.Result -> ResultProcessor a -> ExceptT ResultError IO [a]+processResult res (ResultProcessor proc) = do+	(rows, cols) <- liftIO ((,) <$> P.ntuples res <*> P.nfields res) -instance (Result a, Result b, Result c, Result d, Result e, Result f, Result g) => Result (a, b, c, d, e, f, g) where-	resultProcessor =-		zip7 <$> resultProcessor-		     <*> resultProcessor-		     <*> resultProcessor-		     <*> resultProcessor-		     <*> resultProcessor-		     <*> resultProcessor-		     <*> resultProcessor+	-- Iterate over each row number and run the row processor+	forM [0 .. rows - 1] $ \ row ->+		runReaderT (evalStateT proc 0) (res, row, cols) --- | A row containing all a list of all column values.-newtype RawRow = RawRow [Value]-	deriving (Show, Eq, Ord)+-- | Process one row of the result set.+processOneResult :: P.Result -> ResultProcessor a -> ExceptT ResultError IO (Maybe a)+processOneResult res (ResultProcessor proc) = do+	(rows, cols) <- liftIO ((,) <$> P.ntuples res <*> P.nfields res) -instance Result RawRow where-	resultProcessor = do-		ncols <- numColumns-		foreachRow $ \ row ->-			RawRow <$> forM [0 .. ncols - 1] (cellValue' row)+	if rows > 0 then+		Just <$> runReaderT (evalStateT proc 0) (res, 0, cols)+	else+		pure Nothing

@@ -1,4 +1,4 @@-{-# LANGUAGE TemplateHaskell, RecordWildCards, BangPatterns #-}+{-# LANGUAGE TemplateHaskell, BangPatterns #-}  -- | -- Module:     Database.PostgreSQL.Store.Table@@ -6,341 +6,366 @@ -- License:    BSD3 -- Maintainer: Ole Krüger <ole@vprsm.de> module Database.PostgreSQL.Store.Table (-	TableDescription (..),-	Table (..),-	Row (..),+	-- * Auxiliary data types 	Reference (..),-	HasID (..),++	-- * Table types+	Table (..),+	mkCreateQuery,++	-- * Table generation 	TableConstraint (..),-	mkTable,-	mkCreateQuery+	mkTable ) where  import Control.Monad-import Control.Monad.Trans.Class+import Control.Monad.Except  import Data.Int-import Data.List+import Data.List hiding (insert)+import Data.Proxy import Data.String-import Data.Typeable +import qualified Data.ByteString as B+ import Language.Haskell.TH+import Language.Haskell.TH.Syntax  import Database.PostgreSQL.Store.Query import Database.PostgreSQL.Store.Columns import Database.PostgreSQL.Store.Result import Database.PostgreSQL.Store.Errand --- | Resolved row-data Row a = Row {-	-- | Identifier-	rowID :: !Int64,--	-- | Value-	rowValue :: !a-} deriving (Show, Eq, Ord)+-- | Reference a row of type @a@.+newtype Reference a = Reference { referenceID :: Int64 }+	deriving (Eq, Ord) --- | Reference to a row-newtype Reference a = Reference Int64-	deriving (Show, Eq, Ord)+instance Show (Reference a) where+	show (Reference n) = show n -instance (Table a) => Column (Reference a) where-	pack ref =-		pack (referenceID ref)+instance (QueryTable a) => Column (Reference a) where+	pack ref = pack (referenceID ref) -	unpack val =-		Reference <$> unpack val+	unpack val = Reference <$> unpack val -	describeColumn proxy =-		ColumnDescription {-			columnTypeName = "bigint references \"" ++ tableName ++ "\" (\"" ++ tableIdentifier ++ "\")",-			columnTypeNull = False-		}+	columnTypeName proxy =+		"BIGINT REFERENCES " ++ quoteIdentifier (tableName tableProxy) +++		" (" ++ quoteIdentifier (tableIDName tableProxy) ++ ")" 		where-			coerceProxy :: Proxy (Reference a) -> Proxy a-			coerceProxy _ = Proxy+			tableProxy = (const Proxy :: Proxy (Reference a) -> Proxy a) proxy -			TableDescription {..} =-				describeTable (coerceProxy proxy)+	columnAllowNull _ = False -class (DescribableTable a) => Table a where+instance Result (Reference a) where+	queryResultProcessor = Reference <$> unpackColumn++-- | Qualify @a@ as a table type. 'mkTable' can implement this class for you.+class Table a where 	-- | Insert a row into the table and return a 'Reference' to the inserted row. 	insert :: a -> Errand (Reference a) +	-- | Insert multiple rows into the table at once.+	insertMany :: [a] -> Errand [Reference a]+	insertMany = mapM insert+ 	-- | Find the row identified by the given reference.-	find :: (HasID i) => i a -> Errand (Row a)+	find :: Reference a -> Errand a  	-- | Update an existing row.-	update :: (HasID i) => i a -> a -> Errand ()+	update :: Reference a -> a -> Errand ()  	-- | Delete a row from the table.-	delete :: (HasID i) => i a -> Errand ()+	delete :: Reference a -> Errand ()  	-- | Generate the query which creates this table inside the database.-	-- Use @mkCreateQuery@ for convenience.-	createQuery :: Proxy a -> Query+	-- Use 'mkCreateQuery' for convenience.+	createTableQuery :: Proxy a -> Query -	-- | Extract rows from a result set.-	tableResultProcessor :: ResultProcessor [Row a]+-- | Table field declaration+data TableField = TableField String Type Name -	-- | Extract only a 'Reference' to each row.-	tableRefResultProcessor :: ResultProcessor [Reference a]+-- | Table type declaration+data TableDec = TableDec Name Name [TableField] Pat -instance (Table a) => Result (Row a) where-	resultProcessor = tableResultProcessor+-- | Generate an identifier for a table type.+tableIdentifier :: Name -> String+tableIdentifier name = quoteIdentifier (show name) -instance (Table a) => Result (Reference a) where-	resultProcessor = tableRefResultProcessor+-- | Make a comma-seperated list of identifiers which correspond to given fields.+tableFieldIdentifiers :: [TableField] -> String+tableFieldIdentifiers fields =+	intercalate ", " (map (\ (TableField name _ _) -> quoteIdentifier name) fields) --- | A value of that type contains an ID.-class HasID a where-	-- | Retrieve the underlying ID.-	referenceID :: a b -> Int64+-- | Beginning of a insert statement.+tableInsertStatementBegin :: TableDec -> String+tableInsertStatementBegin (TableDec table _ fields _) =+	"INSERT INTO " +++	tableIdentifier table +++	" (" +++	tableFieldIdentifiers fields +++	") VALUES " -instance HasID Row where-	referenceID (Row rid _) = rid+-- | End of a insert statement.+tableInsertStatementEnd :: String+tableInsertStatementEnd =+	" RETURNING \"$id\"" -instance HasID Reference where-	referenceID (Reference rid) = rid+-- | Call a constructor with some variables.+callConstructor :: Name -> [Name] -> Exp+callConstructor ctor params =+	foldl AppE (ConE ctor) (map VarE params) --- | Unqualify a name.-unqualifyName :: Name -> Name-unqualifyName = mkName . nameBase+-- | Generate the list of selectors.+makeQuerySelectors :: [TableField] -> Q Exp+makeQuerySelectors fields =+	ListE <$> mapM (\ (TableField field _ _) -> [e| SelectorField $(stringE field) |]) fields --- | Generate the insert query for a table.-insertQueryE :: Name -> [Name] -> Q Exp-insertQueryE name fields =-	[e| fromString $(stringE query) |]+-- | Generate the result processor for a table.+makeResultProcessor :: TableDec -> Q Exp+makeResultProcessor (TableDec _ ctor fields _) = do+	bindingNames <- mapM (\ (TableField name _ _) -> newName name) fields+	pure (DoE (map makeBinding bindingNames +++	           [makeConstruction bindingNames])) 	where-		query =-			"INSERT INTO " ++ sanitizeName' name ++ " (" ++-				intercalate ", " columns ++-			") VALUES (" ++-				intercalate ", " values ++-			") RETURNING " ++ identField' name+		-- Bind expression 'name <- unpackColumn'+		makeBinding name =+			BindS (VarP name) (VarE 'unpackColumn) -		columns =-			map (\ nm -> "\"" ++ sanitizeName nm ++ "\"") fields+		-- Last expression 'pure (ctor boundNames...)'+		makeConstruction names =+			NoBindS (AppE (VarE 'pure) (callConstructor ctor names)) -		values =-			map (\ idx -> "$" ++ show idx) [1 .. length fields]+-- | Generate the create query.+makeCreateQuery :: TableDec -> [TableConstraint] -> Q Exp+makeCreateQuery (TableDec table _ fields _) constraints =+	runQueryBuilder $ do+		writeStringCode "CREATE TABLE IF NOT EXISTS " :: QueryBuilder [Q Exp] (Q Exp)+		writeIdentifier (show table)+		writeStringCode " (" --- | Generate the select query for a table row.-findQueryE :: Name -> Q Exp-findQueryE name =-	[e| fromString $(stringE query) |]-	where-		query =-			"SELECT * FROM " ++ sanitizeName' name ++-			" WHERE " ++ identField' name ++ " = $1 LIMIT 1"+		intercalateBuilder (writeStringCode ", ") $+			identDescription :+			map describeField fields +++			map describeConstraint constraints --- | Generate the update query for a table.-updateQueryE :: Name -> [Name] -> Q Exp-updateQueryE name fields =-	[e| fromString $(stringE query) |]+		writeStringCode ")" 	where-		query =-			"UPDATE " ++ sanitizeName' name ++-			" SET " ++ intercalate ", " values ++-			" WHERE " ++ identField' name ++ " = $1"+		identDescription = do+			writeIdentifier "$id"+			writeStringCode "BIGSERIAL NOT NULL PRIMARY KEY" -		values =-			map (\ (nm, idx) -> sanitizeName' nm ++ " = $" ++ show idx)-			    (zip fields [2 .. length fields + 1])+		describeField :: TableField -> QueryBuilder [Q Exp] (Q Exp)+		describeField (TableField name typ _) =+			writeCode [e| fromString (columnDescription (Proxy :: Proxy $(pure typ))+			                                            $(stringE (quoteIdentifier name))) |] --- | Generate the delete query for a table.-deleteQueryE :: Name -> Q Exp-deleteQueryE name =-	[e| fromString $(stringE query) |]-	where-		query =-			"DELETE FROM " ++ sanitizeName' name ++-			" WHERE " ++ identField' name ++ " = $1"+		describeConstraint :: TableConstraint -> QueryBuilder [Q Exp] (Q Exp)+		describeConstraint (Unique names) = do+			writeStringCode "UNIQUE ("+			intercalateBuilder (writeStringCode ", ") $+				map (writeIdentifier . nameBase) names+			writeStringCode ")" --- | Generate the create query for a table.-createQueryE :: Name -> [(Name, Type)] -> [TableConstraint] -> Q Exp-createQueryE name fields constraints =-	[e| fromString ($(stringE queryBegin) ++-	                intercalate ", " ($(stringE anchorDescription) :-	                                  $fieldList ++-	                                  $constraintList) ++-	                $(stringE queryEnd)) |]-	where-		queryBegin = "CREATE TABLE IF NOT EXISTS " ++ sanitizeName' name ++ " ("-		queryEnd = ")"+		describeConstraint (Check code) = do+			writeStringCode "CHECK ("+			writeStringCode code+			writeStringCode ")" -		anchorDescription =-			identField' name ++ " BIGSERIAL NOT NULL PRIMARY KEY"+-- | Generate the query which insert a row.+makeInsertQuery :: TableDec -> Q Exp+makeInsertQuery (TableDec table _ fields _) =+	runQueryBuilder $ do+		writeCode "INSERT INTO " :: QueryBuilder String (Q Exp)+		writeIdentifier (show table)+		writeCode " ("+		intercalateBuilder (writeCode ", ") $+			map (\ (TableField name _ _) -> writeIdentifier name) fields+		writeCode ") VALUES ("+		intercalateBuilder (writeCode ", ") $+			map (\ (TableField _ _ boundName) -> writeParam [e| pack $(varE boundName) |]) fields+		writeCode ") RETURNING "+		writeIdentifier "$id" -		fieldList =-			ListE <$> mapM describeField fields+-- | Generate the query which inserts multiple rows at once.+makeInsertManyQuery :: Name -> TableDec -> Q Exp+makeInsertManyQuery rows dec@(TableDec _ _ fields destructPat) =+	[e|+		let+			writeTuple $(pure destructPat) = do+				writeStringCode "(" :: QueryBuilder B.ByteString Value+				intercalateBuilder (writeStringCode ",") $(ListE <$> mapM packColumn fields)+				writeStringCode ")"+		in runQueryBuilder $ do+			writeStringCode $(stringE (tableInsertStatementBegin dec))+			intercalateBuilder (writeStringCode ",") (map writeTuple $(varE rows))+			writeStringCode $(stringE tableInsertStatementEnd)+	|]+	where+		packColumn (TableField _ _ boundName) = [e| writeColumn $(varE boundName) |] -		describeField (fname, ftype) =-			[e| $(stringE (sanitizeName' fname)) ++ " " ++-			    makeColumnDescription (describeColumn (Proxy :: Proxy $(pure ftype))) |]+-- | Generate the query for finding a row.+makeFindQuery :: Name -> TableDec -> Q Exp+makeFindQuery ref (TableDec table _ fields _) =+	runQueryBuilder $ do+		writeCode "SELECT " :: QueryBuilder String (Q Exp)+		intercalateBuilder (writeCode ", ") $+			map (\ (TableField name _ _) -> writeIdentifier name) fields+		writeCode " FROM "+		writeIdentifier (show table)+		writeCode " WHERE "+		writeIdentifier "$id"+		writeCode " = "+		writeParam [e| pack $(varE ref) |] -		constraintList =-			ListE <$> mapM describeConstraint constraints+-- | Generate the query for updating a row.+makeUpdateQuery :: Name -> TableDec -> Q Exp+makeUpdateQuery ref (TableDec table _ fields _) =+	runQueryBuilder $ do+		writeCode "UPDATE " :: QueryBuilder String (Q Exp)+		writeIdentifier (show table)+		writeCode " SET "+		intercalateBuilder (writeCode ", ") $+			flip map fields $ \ (TableField name _ boundName) -> do+				writeIdentifier name+				writeCode " = "+				writeParam [e| pack $(varE boundName) |]+		writeCode " WHERE "+		writeIdentifier "$id"+		writeCode " = "+		writeParam [e| pack $(varE ref) |] -		describeConstraint cont =-			case cont of-				Unique names ->-					stringE ("UNIQUE (" ++ intercalate ", " (map sanitizeName' names) ++ ")")+-- | Generate the query for deleting a row.+makeDeleteQuery :: Name -> Name -> Q Exp+makeDeleteQuery ref table =+	runQueryBuilder $ do+		writeCode "DELETE FROM " :: QueryBuilder String (Q Exp)+		writeIdentifier (show table)+		writeCode " WHERE "+		writeIdentifier "$id"+		writeCode " = "+		writeParam [e| pack $(varE ref) |] -				ForeignKey names table tableNames ->-					stringE ("FOREIGN KEY (" ++ intercalate ", " (map sanitizeName' names) ++-					         ") REFERENCES " ++ sanitizeName' table ++-					         "(" ++ intercalate ", " (map sanitizeName' tableNames) ++ ")")+-- | Implement relevant instances for the given table type.+implementClasses :: TableDec -> [TableConstraint] -> Q [Dec]+implementClasses dec@(TableDec table _ fields destructPat) constraints =+	[d|+		instance QueryTable $(conT table) where+			tableName _      = $(stringE (show table))+			tableIDName _    = "$id"+			tableSelectors _ = $(makeQuerySelectors fields) --- | Generate an expression which gathers all records from a type and packs them into a list.--- `packParamsE 'row ['field1, 'field2]` generates `[pack (field1 row), pack (field2 row)]`-packParamsE :: Name -> [Name] -> Q Exp-packParamsE row fields =-	ListE <$> mapM extract fields-	where-		extract name =-			[e| pack ($(varE name) $(varE row)) |]+		instance Result $(conT table) where+			queryResultProcessor = $(makeResultProcessor dec) --- | Generate an expression which gathers information about a column.-columnInfoE :: Name -> Q Exp-columnInfoE name =-	[e| columnInfo (fromString $(stringE (sanitizeName' name))) |]+		instance Table $(conT table) where+			insert $(pure destructPat) = do+				rs <- query $(makeInsertQuery dec)+				case rs of+					(ref : _) -> pure ref+					_         -> throwError EmptyResult --- | Generate a query which binds information about a column to the column's info name.-bindColumnInfoS :: Name -> Q Stmt-bindColumnInfoS name =-	BindS (VarP (columnInfoName name)) <$> columnInfoE name+			insertMany [] = pure []+			insertMany rows =+				query $(makeInsertManyQuery 'rows dec) --- | Generate a name which is reserved for information about a column.-columnInfoName :: Name -> Name-columnInfoName name =-	mkName (nameBase name ++ "_info")+			find ref = do+				rs <- query $(makeFindQuery 'ref dec)+				case rs of+					(row : _) -> pure row+					_         -> throwError EmptyResult --- | Generate an expression which unpacks a column at a given row.-unpackColumnE :: Name -> Name -> Q Exp-unpackColumnE row name =-	[e| unpackCellValue $(varE row) $(varE (columnInfoName name)) |]+			update ref $(pure destructPat) =+				query_ $(makeUpdateQuery 'ref dec) --- | Generate a query which binds the unpacked data for a column at a given row to the column's name.-bindColumnS :: Name -> Name -> Q Stmt-bindColumnS row name =-	BindS (VarP (unqualifyName name)) <$> unpackColumnE row name+			delete ref =+				query_ $(makeDeleteQuery 'ref table) --- | Generate an expression which uses a record constructor with variables that correspond to its fields.-constructRecordE :: Name -> [Name] -> Q Exp-constructRecordE ctor fields =-	[e| lift (pure $(pure construction)) |]-	where-		construction = RecConE ctor (map (\ n -> (n, VarE (unqualifyName n))) fields)+			createTableQuery _ =+				$(makeCreateQuery dec constraints)+	|] --- | Generate an expression which unpacks a table instance from a given row.-unpackRowE :: Name -> Name -> [Name] -> Q Exp-unpackRowE ctor row fields = do-	boundFields <- mapM (bindColumnS row) fields-	unboundConstruction <- constructRecordE ctor fields-	pure (DoE (boundFields ++ [NoBindS unboundConstruction]))+-- | Check that each field's type has an implementation of 'Column'.+checkRecordFields :: [VarBangType] -> Q [TableField]+checkRecordFields fields =+	forM fields $ \ (name, _, typ) -> do+		ii <- isInstance ''Column [typ]+		unless ii $+			fail ("Type of field '" ++ show name ++ "' ('" ++ show typ +++			      "') type does not implement '" ++ show ''Column ++ "'") --- | Generate an expression which traverses all rows in order to unpack table instances from them.-unpackRowsE :: Name -> Name -> [Name] -> Q Exp-unpackRowsE table ctor fields =-	[e| do idNfo <- columnInfo (fromString $(stringE (identField' table)))-	       foreachRow $ \ row ->-	           Row <$> unpackCellValue row idNfo-	               <*> $(unpackRowE ctor 'row fields) |]+		TableField (nameBase name) typ <$> newName (nameBase name) --- | Generate an expression which retrieves a table instance from each row.-tableResultProcessorE :: Name -> Name -> [Name] -> Q Exp-tableResultProcessorE table ctor fields = do-	infoBinds <- mapM bindColumnInfoS fields-	rowTraversal <- unpackRowsE table ctor fields-	pure (DoE (infoBinds ++ [NoBindS rowTraversal]))+-- | Check that each constructor parameter type implements 'Column'.+checkNormalFields :: [BangType] -> Q [TableField]+checkNormalFields fields = do+	forM (fields `zip` [1 .. length fields]) $ \ ((_, typ), idx) -> do+		ii <- isInstance ''Column [typ]+		unless ii $+			fail ("Type of constructor parameter #" ++ show idx ++ " ('" ++ show typ +++			      "') type does not implement '" ++ show ''Column ++ "'") --- | Generate an expression which retrieves a reference to each row.-tableRefResultProcessorE :: Name -> Q Exp-tableRefResultProcessorE table =-	[e| do idNfo <- columnInfo (fromString $(stringE (identField' table)))-	       foreachRow (\ row -> Reference <$> unpackCellValue row idNfo) |]+		TableField ("column" ++ show idx) typ <$> newName ("column" ++ show idx) --- | Implement an instance 'Table' for the given type.-implementTableD :: Name -> Name -> [(Name, Type)] -> [TableConstraint] -> Q [Dec]-implementTableD table ctor fields constraints =-	[d| instance DescribableTable $(conT table) where-	        describeTableName _ =-	            $(stringE (sanitizeName table))+-- |+makeCtorPattern :: Name -> [TableField] -> Pat+makeCtorPattern ctor fields =+	ConP ctor (map (\ (TableField _ _ name) -> VarP name) fields) -	        describeTableIdentifier _ =-	            $(stringE (identField table))+-- | Verify that the given constructor is viable and construct a 'TableDec'.+checkTableCtor :: Name -> Con -> Q TableDec+checkTableCtor table (RecC ctor ctorFields) = do+	when (length ctorFields < 1)+	     (fail ("'" ++ show ctor ++ "' must have at least one field")) -	    instance Table $(conT table) where-	        insert row = do-	            rs <- query Query {-	                queryStatement = $(insertQueryE table fieldNames),-	                queryParams    = $(packParamsE 'row fieldNames)-	            }+	fields <- checkRecordFields ctorFields+	pure (TableDec table ctor fields (makeCtorPattern ctor fields)) -	            case rs of-	                (ref : _) -> pure ref-	                _         -> raiseErrandError UnexpectedEmptyResult+checkTableCtor table (NormalC ctor ctorFields) = do+	when (length ctorFields < 1)+	     (fail ("'" ++ show ctor ++ "' must have at least one field")) -	        find ref = do-	            rs <- query Query {-	                queryStatement = $(findQueryE table),-	                queryParams    = [pack (referenceID ref)]-	            }+	fields <- checkNormalFields ctorFields+	pure (TableDec table ctor fields (makeCtorPattern ctor fields)) -	            case rs of-	                (row : _) -> pure row-	                _         -> raiseErrandError UnexpectedEmptyResult+checkTableCtor table _ =+	fail ("'" ++ show table ++ "' must have a normal or record constructor") -	        update ref row =-	            query_ Query {-	                queryStatement = $(updateQueryE table fieldNames),-	                queryParams    = pack (referenceID ref) : $(packParamsE 'row fieldNames)-	            }+-- | Make sure the given declaration can be used, then construct a 'TableDec'.+checkTableDec :: Name -> Dec -> Q TableDec+checkTableDec _ (DataD ctx tableName typeVars kind ctorNames _) = do+	when (length ctx > 0)+	     (fail ("'" ++ show tableName ++ "' must not have a context")) -	        delete ref =-	            query_ Query {-	                queryStatement = $(deleteQueryE table),-	                queryParams    = [pack (referenceID ref)]-	            }+	when (length typeVars > 0)+	     (fail ("'" ++ show tableName ++ "' must not use type variables")) -	        createQuery _ =-	            Query {-	                queryStatement = $(createQueryE table fields constraints),-	                queryParams    = []-	            }+	when (length ctorNames /= 1)+	     (fail ("'" ++ show tableName ++ "' must have 1 constructor")) -	        tableResultProcessor =-	            $(tableResultProcessorE table ctor fieldNames)+	when (kind /= Nothing && kind /= Just StarT)+	     (fail ("'" ++ show tableName ++ "' must have kind *")) -	        tableRefResultProcessor =-	            $(tableRefResultProcessorE table) |]-	where-		fieldNames = map fst fields+	let [ctorName] = ctorNames --- | Check that all field types have an instance of Column.-validateFields :: [(Name, Type)] -> Q ()-validateFields fields =-	forM_ fields $ \ (name, typ) -> do-		ii <- isInstance ''Column [typ]-		unless ii $-			fail ("\ESC[35m" ++ show name ++ "\ESC[0m's type does not have an instance of \ESC[34mColumn\ESC[0m")+	checkTableCtor tableName ctorName +checkTableDec tableName _ =+	fail ("'" ++ show tableName ++ "' must declare a data type")+ -- | Options to 'mkTable'. data TableConstraint 	= Unique [Name] 	  -- ^ A combination of fields must be unique.-	  --   @Unique ['name1, 'name2, ...]@ works analogous to the following table constraint:-	  --   @UNIQUE (name1, name2, ...)@-	| ForeignKey [Name] Name [Name]-	  -- ^ A combination of fields references another combination of fields from a different table.-	  --   @ForeignKey ['name1, 'name2, ...] ''RefTable ['refname1, 'refname2, ...]@ works like this-	  --   table constraint in SQL:-	  --   @FOREIGN KEY (name1, name2, ...) REFERENCES RefTable(refname1, refname2, ...)@+	  --   @Unique ['name1, 'name2, ...]@ works analogous to the table constraint+	  --   @UNIQUE (name1, name2, ...)@ in SQL.+	| Check String+	  -- ^ The given statement must evaluate to true. Just like @CHECK (statement)@ in SQL. 	deriving (Show, Eq, Ord) --- | Implement 'Table' for a data type. The given type must fulfill these requirements:+-- | Implement the type classes 'QueryTable', 'Table' and 'Result' for the given type. --+-- The given type must fulfill these requirements:+-- --   * Data type --   * No type context --   * No type variables@@ -350,65 +375,45 @@ -- Example: -- -- @--- {-\# LANGUAGE TemplateHaskell \#-}+-- {-\# LANGUAGE TemplateHaskell, QuasiQuotes \#-} -- module Movies where -- -- ... -- -- data Movie = Movie {---     movieTitle :: String,---     movieYear  :: Int--- } deriving Show+--     movieTitle :: 'String',+--     movieYear  :: 'Int'+-- } deriving 'Show' -- -- 'mkTable' ''Movie [] -- -- data Actor = Actor {---     actorName :: String,---     actorAge  :: Int--- } deriving Show+--     actorName :: 'String',+--     actorAge  :: 'Int'+-- } deriving 'Show' ----- 'mkTable' ''Actor []+-- 'mkTable' ''Actor ['Unique' ['actorName], 'Check' ['pgss'| actorAge >= 18 |]] -- -- data MovieCast = MovieCast { --     movieCastMovie :: 'Reference' Movie, --     movieCastActor :: 'Reference' Actor--- } deriving Show+-- } deriving 'Show' ----- 'mkTable' ''MovieCast []+-- 'mkTable' ''MovieCast ['Unique' ['movieCastMovie, 'movieCastActor]] -- @ --+-- In this example, 'Reference' takes care of adding the @FOREIGN KEY@ constraint, so we don't have+-- to.+-- mkTable :: Name -> [TableConstraint] -> Q [Dec] mkTable name constraints = do 	info <- reify name 	case info of-		TyConI dec ->-			case dec of-				DataD [] _ [] [RecC ctor records@(_ : _)] _ -> do-					let fields = map (\ (fn, _, ft) -> (fn, ft)) records-					validateFields fields-					implementTableD name ctor fields constraints--				DataD (_ : _) _ _ _ _ ->-					fail ("\ESC[34m" ++ show name ++ "\ESC[0m has a context")--				DataD _ _ (_ : _) _ _ ->-					fail ("\ESC[34m" ++ show name ++ "\ESC[0m has one or more type variables")--				DataD _ _ _ [] _ ->-					fail ("\ESC[34m" ++ show name ++ "\ESC[0m does not have a constructor")--				DataD _ _ _ (_ : _ : _) _ ->-					fail ("\ESC[34m" ++ show name ++ "\ESC[0m has more than one constructor")--				DataD _ _ _ [RecC _ []] _ ->-					fail ("\ESC[34m" ++ show name ++ "\ESC[0m has an empty record constructor")--				DataD _ _ _ [_] _ ->-					fail ("\ESC[34m" ++ show name ++ "\ESC[0m does not have a record constructor")--				_ -> fail ("\ESC[34m" ++ show name ++ "\ESC[0m is not an eligible data type")+		TyConI dec -> do+			tableDec <- checkTableDec name dec+			implementClasses tableDec constraints -		_ -> fail ("\ESC[34m" ++ show name ++ "\ESC[0m is not a type constructor")+		_ -> fail ("'" ++ show name ++ "' is not a type constructor")  -- | Check if the given name refers to a type. isType :: Name -> Q Bool@@ -418,7 +423,7 @@ 		TyConI _ -> True 		_        -> False --- | Generate a 'Query' which will create the table described my the given type.+-- | Generate a 'Query' expression which will create the table described by the given type. -- -- Example: --@@ -436,4 +441,4 @@ 	unless it (fail "Given name does not refer to a type.")  	-- Actual splice-	[e| createQuery (Proxy :: Proxy $(pure (ConT name))) |]+	[e| createTableQuery (Proxy :: Proxy $(pure (ConT name))) |]

@@ -1,121 +0,0 @@-module Database.PostgreSQL.Store.ColumnsSpec (columnsSpec) where--import           Data.Int-import           Data.Typeable-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as BL-import qualified Data.Text as T-import qualified Data.Text.Lazy as TL--import           Test.QuickCheck-import           Test.Hspec--import           Database.PostgreSQL.Store.Columns---- | Pack and unpack value to test if the input value is the same as the output value.-testColumnIsomorphism :: (Column a, Show a, Eq a) => a -> Expectation-testColumnIsomorphism val =-	shouldBe (unpack (pack val)) (Just val)---- | Quick check an instance of Column to see if it behaves isomorphic.-propColumnIsomorphism :: (Column a, Arbitrary a, Eq a, Show a) => Proxy a -> Property-propColumnIsomorphism proxy =-	property (compare proxy)-	where-		compare :: (Column a, Arbitrary a, Eq a, Show a) => Proxy a -> a -> Bool-		compare _ x =-			unpack (pack x) == Just x---- | Quick check an instance of Column which has to be generated first, because it does not have an---   instance of Arbitrary.-propColumnIsomorphism' :: (Arbitrary b, Show b, Column a, Eq a, Show a) => ([b] -> a) -> Property-propColumnIsomorphism' make =-	property (\ xs -> unpack (pack (make xs)) == Just (make xs))---- | Test for instances of Column-columnsSpec :: Spec-columnsSpec = do-	describe "instance Column Bool" $-		it "must behave isomorphic" $ do-			testColumnIsomorphism True-			testColumnIsomorphism False--	describe "instance Column Int" $ do-		it "must behave isomorphic" $ do-			testColumnIsomorphism (minBound :: Int)-			testColumnIsomorphism (0 :: Int)-			testColumnIsomorphism (maxBound :: Int)--		it "must behave isomorphic (using QuickCheck)" $-			propColumnIsomorphism (Proxy :: Proxy Int)--	describe "instance Column Int8" $ do-		it "must behave isomorphic" $ do-			testColumnIsomorphism (minBound :: Int8)-			testColumnIsomorphism (0 :: Int8)-			testColumnIsomorphism (maxBound :: Int8)--		it "must behave isomorphic (using QuickCheck)" $-			propColumnIsomorphism (Proxy :: Proxy Int8)--	describe "instance Column Int16" $ do-		it "must behave isomorphic" $ do-			testColumnIsomorphism (minBound :: Int16)-			testColumnIsomorphism (0 :: Int16)-			testColumnIsomorphism (maxBound :: Int16)--		it "must behave isomorphic (using QuickCheck)" $-			propColumnIsomorphism (Proxy :: Proxy Int16)--	describe "instance Column Int32" $ do-		it "must behave isomorphic" $ do-			testColumnIsomorphism (minBound :: Int32)-			testColumnIsomorphism (0 :: Int32)-			testColumnIsomorphism (maxBound :: Int32)--		it "must behave isomorphic (using QuickCheck)" $-			propColumnIsomorphism (Proxy :: Proxy Int32)--	describe "instance Column Int64" $ do-		it "must behave isomorphic" $ do-			testColumnIsomorphism (minBound :: Int64)-			testColumnIsomorphism (0 :: Int64)-			testColumnIsomorphism (maxBound :: Int64)--		it "must behave isomorphic (using QuickCheck)" $-			propColumnIsomorphism (Proxy :: Proxy Int64)--	describe "instance Column [Char]" $ do-		it "must behave isomorphic" $-			testColumnIsomorphism ([] :: [Char])--		it "must behave isomorphic (using QuickCheck)" $-			propColumnIsomorphism (Proxy :: Proxy [Char])--	describe "instance Column B.ByteString" $ do-		it "must behave isomorphic" $-			testColumnIsomorphism B.empty--		it "must behave isomorphic (using QuickCheck)" $-			propColumnIsomorphism' B.pack--	describe "instance Column BL.ByteString" $ do-		it "must behave isomorphic" $-			testColumnIsomorphism BL.empty--		it "must behave isomorphic (using QuickCheck)" $-			propColumnIsomorphism' BL.pack--	describe "instance Column T.Text" $ do-		it "must behave isomorphic" $-			testColumnIsomorphism T.empty--		it "must behave isomorphic (using QuickCheck)" $-			propColumnIsomorphism' T.pack--	describe "instance Column TL.Text" $ do-		it "must behave isomorphic" $-			testColumnIsomorphism TL.empty--		it "must behave isomorphic (using QuickCheck)" $-			propColumnIsomorphism' TL.pack

@@ -1,36 +0,0 @@-{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes #-}--module Database.PostgreSQL.Store.QuerySpec (querySpec) where--import Test.Hspec--import Data.String-import Data.Typeable--import Database.PostgreSQL.Store-import Database.PostgreSQL.Store.Query-import Database.PostgreSQL.Store.Columns--data MyType = MyConstructor Int-	deriving (Show)--instance DescribableTable MyType where-	describeTableName _ = "InsertTableName"-	describeTableIdentifier _ = "InsertTableIdentifier"--testValue :: Int-testValue = 1337--querySpec :: Spec-querySpec =-	describe "parseStoreQueryE" $ do-		it "must resolve tables names correctly" $-			queryStatement [pgsq|MyType|]-				`shouldBe` fromString ("\"" ++ describeTableName (Proxy :: Proxy MyType) ++ "\"")--		it "must resolve identifier column names correctly" $-			queryStatement [pgsq|&MyType|]-				`shouldBe` fromString ("\"" ++ describeTableIdentifier (Proxy :: Proxy MyType) ++ "\"")--		it "must insert and pack variables correctly" $-			[pgsq|$testValue|] `shouldBe` Query "$1" [pack testValue]

@@ -1,94 +0,0 @@-{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes #-}--module Database.PostgreSQL.Store.TableSpec (tableSpec) where--import           Test.Hspec-import           Test.QuickCheck-import           Test.QuickCheck.Monadic--import           Data.Int-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as BL-import qualified Data.Text as T-import qualified Data.Text.Lazy as TL--import           Database.PostgreSQL.Store-import qualified Database.PostgreSQL.LibPQ as P--data TestTable = TestTable {-	ttBool           :: Bool,-	ttInt            :: Int,-	ttInt8           :: Int8,-	ttInt16          :: Int16,-	ttInt32          :: Int32,-	ttInt64          :: Int64,-	ttString         :: String,-	ttText           :: T.Text,-	ttLazyText       :: TL.Text,-	ttByteString     :: B.ByteString,-	ttLazyByteString :: BL.ByteString,-	ttMaybeInt       :: Maybe Int-} deriving (Show, Eq, Ord)--instance Arbitrary TestTable where-	arbitrary =-		TestTable <$> arbitrary-		          <*> arbitrary-		          <*> arbitrary-		          <*> arbitrary-		          <*> arbitrary-		          <*> arbitrary-		          <*> arbitrary-		          <*> fmap T.pack arbitrary-		          <*> fmap TL.pack arbitrary-		          <*> fmap B.pack arbitrary-		          <*> fmap BL.pack arbitrary-		          <*> arbitrary--mkTable ''TestTable []--tableSpec :: P.Connection -> Spec-tableSpec con = do-	describe "Table" $ do-		it "create" $ do-			result <- runErrand con (query_ $(mkCreateQuery ''TestTable)) :: IO (Either ErrandError ())-			result `shouldBe` Right ()--	describe "Row" $ do-		it "insert/find/update/find/delete" $ monadicIO $ do-			row1 <- pick arbitrary :: PropertyM IO TestTable-			eRef <- run (runErrand con (insert row1))--			assert $-				case eRef of-					Right (Reference _) -> True-					_                   -> False--			let Right ref = eRef-			eRow1 <- run (runErrand con (find ref))--			assert $-				case eRow1 of-					Right (Row _ row1') -> row1' == row1-					_                   -> False--			row2 <- pick arbitrary :: PropertyM IO TestTable-			eUpdate <- run (runErrand con (update ref row2))--			assert (eUpdate == Right ())--			eRow2 <- run (runErrand con (find ref))--			assert $-				case eRow2 of-					Right (Row _ row2') -> row2' == row2-					_                   -> False--			eDelete <- run (runErrand con (delete ref))--			assert (eDelete == Right ())--	describe "Table" $ do-		it "drop" $ do-			result <- runErrand con (query_ [pgsq| DROP TABLE TestTable |]) :: IO (Either ErrandError ())-			result `shouldBe` Right ()

@@ -1,40 +1,29 @@ module Main (main) where  import           Test.Hspec--import           Control.Monad+import           Test.Database.PostgreSQL.Store -import qualified Data.Text as T-import qualified Data.Text.Encoding as T+import           Data.String -import           Database.PostgreSQL.Store.ColumnsSpec-import           Database.PostgreSQL.Store.TableSpec-import           Database.PostgreSQL.Store.QuerySpec import qualified Database.PostgreSQL.LibPQ as P  import           System.Environment --- | Test which will only be executed if 'PGINFO' environment variable is set-liveTests :: String -> Spec-liveTests pgInfo = do-	(con, status) <- runIO $ do-		con <- P.connectdb (T.encodeUtf8 (T.pack pgInfo))-		status <- P.status con-		pure (con, status)--	describe "Database connection" $-		it "must be established" $-			status `shouldBe` P.ConnectionOk+connectMaybe :: String -> IO (Maybe P.Connection)+connectMaybe info = do+	con <- P.connectdb (fromString info)+	status <- P.status con -	when (status == P.ConnectionOk) (afterAll_ (P.finish con) (tableSpec con))+	pure $+		if status == P.ConnectionOk then+			Just con+		else+			Nothing  -- | Test entry point main :: IO ()-main = hspec $ do-	columnsSpec-	querySpec+main = do+	mbInfo <- lookupEnv "PGINFO"+	mbCon <- maybe (pure Nothing) connectMaybe mbInfo -	mbPGInfo <- runIO (lookupEnv "PGINFO")-	case mbPGInfo of-		Just pgInfo -> liveTests pgInfo-		Nothing     -> runIO (putStrLn "Environment variable 'PGINFO' is missing")+	hspec (allSpecs mbCon)

@@ -0,0 +1,17 @@+module Test.Database.PostgreSQL.Store (+	allSpecs+) where++import           Test.Hspec++import           Test.Database.PostgreSQL.Store.Columns+import           Test.Database.PostgreSQL.Store.Query+import           Test.Database.PostgreSQL.Store.Table++import qualified Database.PostgreSQL.LibPQ as P++allSpecs :: Maybe P.Connection -> Spec+allSpecs mbCon = do+	allColumnsSpecs mbCon+	allTableSpecs mbCon+	allQuerySpecs

@@ -0,0 +1,117 @@+{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes #-}++module Test.Database.PostgreSQL.Store.Columns (+	allColumnsSpecs+) where++import           Test.Hspec+import           Test.QuickCheck+import           Test.QuickCheck.Monadic++import           Control.Monad.Trans++import           Data.Int+import           Data.Word+import           Data.Proxy++import           Database.PostgreSQL.Store.Query+import           Database.PostgreSQL.Store.Columns+import           Database.PostgreSQL.Store.Result+import           Database.PostgreSQL.Store.Errand++import qualified Database.PostgreSQL.LibPQ as P++testLivePackUnpack :: (Column a, Arbitrary a, Eq a, Show a) => Proxy a -> P.Connection -> Property+testLivePackUnpack proxy con =+	property $ coerceParam proxy $ \ value -> monadicIO $ do+		lift $ do+			res <- runErrand con (queryWith (Query "SELECT $1" [pack value]) unpackColumn)++			shouldBe res (Right [value])+	where+		coerceParam :: Proxy a -> (a -> b) -> a -> b+		coerceParam _ f x = f x++testPackUnpack :: (Column a, Arbitrary a, Eq a, Show a) => Proxy a -> Property+testPackUnpack proxy =+	property (compare proxy)+	where+		compare :: (Column a, Eq a) => Proxy a -> a -> Bool+		compare _ x = unpack (pack x) == Just x++allColumnsSpecs :: Maybe P.Connection -> Spec+allColumnsSpecs mbCon = do+	describe "Database.PostgreSQL.Store.Columns" $ do+		describe "instance (Column a) => Column (Maybe a)" $+			it "behaves isomorphic" (testPackUnpack (Proxy :: Proxy (Maybe Bool)))++		describe "instance Column Bool" $+			it "behaves isomorphic" (testPackUnpack (Proxy :: Proxy Bool))++		describe "instance Column Int" $+			it "behaves isomorphic" (testPackUnpack (Proxy :: Proxy Int))++		describe "instance Column Int8" $+			it "behaves isomorphic" (testPackUnpack (Proxy :: Proxy Int8))++		describe "instance Column Int16" $+			it "behaves isomorphic" (testPackUnpack (Proxy :: Proxy Int16))++		describe "instance Column Int32" $+			it "behaves isomorphic" (testPackUnpack (Proxy :: Proxy Int32))++		describe "instance Column Int64" $+			it "behaves isomorphic" (testPackUnpack (Proxy :: Proxy Int64))++		describe "instance Column Word" $+			it "behaves isomorphic" (testPackUnpack (Proxy :: Proxy Word))++		describe "instance Column Word8" $+			it "behaves isomorphic" (testPackUnpack (Proxy :: Proxy Word8))++		describe "instance Column Word16" $+			it "behaves isomorphic" (testPackUnpack (Proxy :: Proxy Word16))++		describe "instance Column Word32" $+			it "behaves isomorphic" (testPackUnpack (Proxy :: Proxy Word32))++		describe "instance Column Word64" $+			it "behaves isomorphic" (testPackUnpack (Proxy :: Proxy Word64))++	maybe (pure ()) liveSpecs mbCon++liveSpecs :: P.Connection -> Spec+liveSpecs con =+	describe "Database.PostgreSQL.Store.Columns (live)" $ do+		describe "instance Column Bool" $+			it "behaves isomorphic" (testLivePackUnpack (Proxy :: Proxy Bool) con)++		describe "instance Column Int" $+			it "behaves isomorphic" (testLivePackUnpack (Proxy :: Proxy Int) con)++		describe "instance Column Int8" $+			it "behaves isomorphic" (testLivePackUnpack (Proxy :: Proxy Int8) con)++		describe "instance Column Int16" $+			it "behaves isomorphic" (testLivePackUnpack (Proxy :: Proxy Int16) con)++		describe "instance Column Int32" $+			it "behaves isomorphic" (testLivePackUnpack (Proxy :: Proxy Int32) con)++		describe "instance Column Int64" $+			it "behaves isomorphic" (testLivePackUnpack (Proxy :: Proxy Int64) con)++		describe "instance Column Word" $+			it "behaves isomorphic" (testLivePackUnpack (Proxy :: Proxy Word) con)++		describe "instance Column Word8" $+			it "behaves isomorphic" (testLivePackUnpack (Proxy :: Proxy Word8) con)++		describe "instance Column Word16" $+			it "behaves isomorphic" (testLivePackUnpack (Proxy :: Proxy Word16) con)++		describe "instance Column Word32" $+			it "behaves isomorphic" (testLivePackUnpack (Proxy :: Proxy Word32) con)++		describe "instance Column Word64" $+			it "behaves isomorphic" (testLivePackUnpack (Proxy :: Proxy Word64) con)

@@ -0,0 +1,92 @@+{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes #-}++module Test.Database.PostgreSQL.Store.Query (+	allQuerySpecs+) where++import Test.Hspec++import Database.PostgreSQL.Store.Query+import Database.PostgreSQL.Store.Columns++data TestTable = TestTable+	deriving (Show, Eq, Ord)++instance QueryTable TestTable where+	tableName _      = "T"+	tableIDName _    = "a"+	tableSelectors _ = [SelectorField "b", SelectorField "c"]++testVariable :: Int+testVariable = 1337++allQuerySpecs :: Spec+allQuerySpecs =+	describe "Database.PostgreSQL.Store.Query" $+		describe "pgsq" $ do+			it "resolves table names" $ do+				shouldBe [pgsq|@TestTable|] (Query "\"T\"" [])+				shouldBe [pgsq|@Test.Database.PostgreSQL.Store.Query.TestTable|] [pgsq|@TestTable|]+				shouldBe [pgsq|@TestTable.b|] (Query "\"T\".b" [])+				shouldBe [pgsq|@TestTable."b"|] (Query "\"T\".\"b\"" [])++			it "resolves identifier fields" $ do+				shouldBe [pgsq|&TestTable|] (Query "\"T\".\"a\"" [])+				shouldBe [pgsq|&Test.Database.PostgreSQL.Store.Query.TestTable|] [pgsq|&TestTable|]++			it "resolves selectors" $ do+				shouldBe [pgsq|#TestTable|] (Query "\"T\".\"b\", \"T\".\"c\"" [])+				shouldBe [pgsq|#TestTable|] [pgsq|#Test.Database.PostgreSQL.Store.Query.TestTable|]++			it "embeds variables" $ do+				let i = testVariable+				shouldBe [pgsq|$testVariable $i|] (Query "$1 $2" [pack testVariable, pack i])++			it "ignores operator #" $ do+				shouldBe [pgsq|1 # 2|]       (Query "1 # 2" [])+				shouldBe [pgsq|a # b|]       (Query "a # b" [])+				shouldBe [pgsq|a # T|]       (Query "a # T" [])+				shouldBe [pgsq|a # T.a|]     (Query "a # T.a" [])+				shouldBe [pgsq|a # "T"|]     (Query "a # \"T\"" [])+				shouldBe [pgsq|a # "T"."a"|] (Query "a # \"T\".\"a\"" [])+				shouldBe [pgsq|1#2|]         (Query "1#2" [])+				shouldBe [pgsq|a#b|]         (Query "a#b" [])+				shouldBe [pgsq|a#(T)|]       (Query "a#(T)" [])+				shouldBe [pgsq|a#(T.a)|]     (Query "a#(T.a)" [])+				shouldBe [pgsq|a#"T"|]       (Query "a#\"T\"" [])+				shouldBe [pgsq|a#"T"."a"|]   (Query "a#\"T\".\"a\"" [])++			it "ignores operator &" $ do+				shouldBe [pgsq|1 & 2|]       (Query "1 & 2" [])+				shouldBe [pgsq|a & b|]       (Query "a & b" [])+				shouldBe [pgsq|a & T|]       (Query "a & T" [])+				shouldBe [pgsq|a & T.a|]     (Query "a & T.a" [])+				shouldBe [pgsq|a & "T"|]     (Query "a & \"T\"" [])+				shouldBe [pgsq|a & "T"."a"|] (Query "a & \"T\".\"a\"" [])+				shouldBe [pgsq|1&2|]         (Query "1&2" [])+				shouldBe [pgsq|a&b|]         (Query "a&b" [])+				shouldBe [pgsq|a&(T)|]       (Query "a&(T)" [])+				shouldBe [pgsq|a&(T.a)|]     (Query "a&(T.a)" [])+				shouldBe [pgsq|a&"T"|]       (Query "a&\"T\"" [])+				shouldBe [pgsq|a&"T"."a"|]   (Query "a&\"T\".\"a\"" [])++			it "ignores operator @" $ do+				shouldBe [pgsq|@-5|]      (Query "@-5" [])+				shouldBe [pgsq|@(-5)|]    (Query "@(-5)" [])+				shouldBe [pgsq|@a|]       (Query "@a" [])+				shouldBe [pgsq|@(a)|]     (Query "@(a)" [])+				shouldBe [pgsq|@(T)|]     (Query "@(T)" [])+				shouldBe [pgsq|@(T.a)|]   (Query "@(T.a)" [])+				shouldBe [pgsq|@"a"|]     (Query "@\"a\"" [])+				shouldBe [pgsq|@"T"|]     (Query "@\"T\"" [])+				shouldBe [pgsq|@"T"."a"|] (Query "@\"T\".\"a\"" [])++			it "ignores bad use of $" $ do+				shouldBe [pgsq|$1|]       (Query "$1" [])+				shouldBe [pgsq|$(1)|]     (Query "$(1)" [])+				shouldBe [pgsq|$(a)|]     (Query "$(a)" [])+				shouldBe [pgsq|$(T)|]     (Query "$(T)" [])+				shouldBe [pgsq|$(T.a)|]   (Query "$(T.a)" [])+				shouldBe [pgsq|$"a"|]     (Query "$\"a\"" [])+				shouldBe [pgsq|$"T"|]     (Query "$\"T\"" [])+				shouldBe [pgsq|$"T"."a"|] (Query "$\"T\".\"a\"" [])

@@ -0,0 +1,140 @@+{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes #-}++module Test.Database.PostgreSQL.Store.Table (+	allTableSpecs+) where++import           Test.Hspec++import           Data.Proxy++import           Database.PostgreSQL.Store.Table+import           Database.PostgreSQL.Store.Query+import           Database.PostgreSQL.Store.Errand++import qualified Database.PostgreSQL.LibPQ as P++data OnlyEvens = OnlyEvens {+	value :: Int+} deriving (Show, Eq)++mkTable ''OnlyEvens+	[Unique ['value],+	 Check [pgss| value % 2 = 0 |]]++allTableSpecs :: Maybe P.Connection -> Spec+allTableSpecs mbCon = do+	maybe (pure ()) liveSpecs mbCon++dropTable :: P.Connection -> IO ()+dropTable con =+	() <$ runErrand con (query_ [pgsq| DROP TABLE @OnlyEvens |])++clearTable :: P.Connection -> IO ()+clearTable con =+	() <$ runErrand con (query_ [pgsq| DELETE FROM @OnlyEvens |])++liveSpecs :: P.Connection -> Spec+liveSpecs con =+	describe "Database.PostgreSQL.Store.Table (live)" $+		afterAll_ (dropTable con) $ describe "auto-generated instance Table" $+			after_ (clearTable con) $ do+				it "creates tables" $ do+					res1 <- runErrand con $+						query_ $(mkCreateQuery ''OnlyEvens)+					shouldBe res1 (Right ())++					-- Table exists now+					let table = tableName (Proxy :: Proxy OnlyEvens)+					res2 <- runErrand con $+						query [pgsq| SELECT COUNT(*) FROM pg_tables WHERE tablename = $table |]+					shouldBe res2 (Right [Single (1 :: Int)])++				it "inserts a rows" $ do+					res1 <- runErrand con (insert (OnlyEvens 2))+					shouldSatisfy res1 $ \ r ->+						case r of+							Right (Reference _) -> True+							_                   -> False++					-- Has been inserted correctly+					res2 <- runErrand con $+						query [pgsq| SELECT #OnlyEvens FROM @OnlyEvens |]+					shouldBe res2 (Right [OnlyEvens 2])++				it "respects constraints while inserting" $ do+					-- Violate UNIQUE+					res3 <- runErrand con $ do+						insert (OnlyEvens 2)+						insert (OnlyEvens 2)+					shouldSatisfy res3 $ \ r ->+						case r of+							Left (ExecError _ UniqueViolation _ _ _) -> True+							_                          -> False++					-- Violate CHECK+					res4 <- runErrand con (insert (OnlyEvens 1))+					shouldSatisfy res4 $ \ r ->+						case r of+							Left (ExecError _ CheckViolation _ _ _) -> True+							_                         -> False++				it "inserts many rows" $ do+					res1 <- runErrand con (insertMany (map OnlyEvens [2, 4 .. 100]))+					shouldSatisfy res1 $ \ r ->+						case r of+							Right xs -> length xs == 50+							_        -> False++					-- Verify that there are actually 50 present+					res2 <- runErrand con $+						query [pgsq| SELECT COUNT(*) FROM @OnlyEvens |]+					shouldBe res2 (Right [Single (50 :: Int)])++				it "finds a row" $ do+					res1 <- runErrand con $ do+						ref <- insert (OnlyEvens 4)+						find ref+					shouldBe res1 (Right (OnlyEvens 4))++				it "finds many rows" $+					pendingWith "Not yet implemented"++				it "updates a row" $ do+					res1 <- runErrand con $ do+						ref <- insert (OnlyEvens 4)+						update ref (OnlyEvens 6)+						find ref+					shouldBe res1 (Right (OnlyEvens 6))++				it "respects constraints while updating" $ do+					-- Violate UNIQUE+					res1 <- runErrand con $ do+						insert (OnlyEvens 2)+						ref <- insert (OnlyEvens 4)+						update ref (OnlyEvens 2)+					shouldSatisfy res1 $ \ r ->+						case r of+							Left (ExecError _ UniqueViolation _ _ _) -> True+							_                          -> False++					-- Vioate CHECK+					res2 <- runErrand con $ do+						ref <- insert (OnlyEvens 6)+						update ref (OnlyEvens 7)+					shouldSatisfy res2 $ \ r ->+						case r of+							Left (ExecError _ CheckViolation _ _ _) -> True+							_                         -> False++				it "updates many rows" $+					pendingWith "Not yet implemented"++				it "deletes a row" $ do+					res1 <- runErrand con $ do+						ref <- insert (OnlyEvens 2)+						delete ref+					shouldBe res1 (Right ())++				it "deletes many rows" $+					pendingWith "Not yet implemented"