pg-store 0.1.1 → 0.2

raw patch · 21 files changed

+1863/−1885 lines, 21 filesdep +aesondep +blaze-builderdep +haskell-src-metadep −QuickCheckdep −hspecdep −pg-storedep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: aeson, blaze-builder, haskell-src-meta, scientific

Dependencies removed: QuickCheck, hspec, pg-store

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• pg-store.cabal +14/−20
• src/Database/PostgreSQL/Store.hs +34/−32
• src/Database/PostgreSQL/Store/ColumnEntity.hs +188/−0
• src/Database/PostgreSQL/Store/Columns.hs +0/−369
• src/Database/PostgreSQL/Store/Entity.hs +418/−0
• src/Database/PostgreSQL/Store/Errand.hs +102/−67
• src/Database/PostgreSQL/Store/Generics.hs +306/−0
• src/Database/PostgreSQL/Store/OIDs.hs +0/−91
• src/Database/PostgreSQL/Store/Query.hs +15/−435
• src/Database/PostgreSQL/Store/Query/Builder.hs +131/−0
• src/Database/PostgreSQL/Store/Query/TH.hs +230/−0
• src/Database/PostgreSQL/Store/Result.hs +0/−82
• src/Database/PostgreSQL/Store/RowParser.hs +175/−0
• src/Database/PostgreSQL/Store/Table.hs +178/−394
• src/Database/PostgreSQL/Store/Types.hs +28/−0
• src/Database/PostgreSQL/Store/Utilities.hs +44/−0
• tests/Main.hs +0/−29
• tests/Test/Database/PostgreSQL/Store.hs +0/−17
• tests/Test/Database/PostgreSQL/Store/Columns.hs +0/−117
• tests/Test/Database/PostgreSQL/Store/Query.hs +0/−92
• tests/Test/Database/PostgreSQL/Store/Table.hs +0/−140

@@ -1,5 +1,5 @@ name:                pg-store-version:             0.1.1+version:             0.2 category:            Database synopsis:            Simple storage interface to PostgreSQL description:         Simple storage interface to PostgreSQL@@ -21,24 +21,18 @@   default-language: Haskell2010   build-depends:    base >= 4.9 && < 5,                     template-haskell >= 2.11 && < 3,-                    bytestring, text, postgresql-libpq, attoparsec, mtl, time+                    bytestring, blaze-builder, text, postgresql-libpq, attoparsec, mtl, time,+                    haskell-src-meta, aeson, scientific   hs-source-dirs:   src-  exposed-modules:  Database.PostgreSQL.Store.Result,-                    Database.PostgreSQL.Store.Columns,-                    Database.PostgreSQL.Store.Query,-                    Database.PostgreSQL.Store.Errand,-                    Database.PostgreSQL.Store.Table,-                    Database.PostgreSQL.Store.OIDs,+  exposed-modules:  Database.PostgreSQL.Store.RowParser+                    Database.PostgreSQL.Store.Errand+                    Database.PostgreSQL.Store.Query.Builder+                    Database.PostgreSQL.Store.Query.TH+                    Database.PostgreSQL.Store.Query+                    Database.PostgreSQL.Store.Types+                    Database.PostgreSQL.Store.Generics+                    Database.PostgreSQL.Store.Entity+                    Database.PostgreSQL.Store.ColumnEntity+                    Database.PostgreSQL.Store.Table                     Database.PostgreSQL.Store--test-suite tests-  type:             exitcode-stdio-1.0-  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, mtl-  hs-source-dirs:   tests-  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+  other-modules:    Database.PostgreSQL.Store.Utilities

@@ -1,52 +1,54 @@ -- | -- Module:     Database.PostgreSQL.Store--- Copyright:  (c) Ole Krüger 2015-2016+-- Copyright:  (c) Ole Krüger 2016 -- License:    BSD3 -- Maintainer: Ole Krüger <ole@vprsm.de> module Database.PostgreSQL.Store (-	-- * Errands+	-- * Errand 	Errand,-	ErrandError (..),-	ErrorCode (..),-	ExecStatus (..), 	runErrand,+ 	execute,+	execute', 	query,-	query_, 	queryWith, -	-- * Queries+	insert,+	insertMany,+	deleteAll,+	findAll,+	create,++	-- * Query 	Query (..), 	pgsq,-	pgss,--	QueryTable (..),-	SelectorElement (..),--	-- * Values-	Value (..),-	Column (..),--	-- * Results-	Result (..),-	ResultProcessor,-	ResultError (..),-	skipColumn,-	unpackColumn,+	castQuery, -	Single (..),-	Reference (..),+	-- * Entity+	Entity (..),  	-- * Tables+	TableEntity (..),+	ColumnEntity (..),+ 	Table (..),-	mkCreateQuery,+	ColumnType (..),+	Column (..), -	mkTable,-	TableConstraint (..)+	-- * Errors+	ErrandError (..),+	ErrorCode (..),+	P.ExecStatus,+	RowError (..),+	RowErrorLocation (..),+	RowErrorDetail (..) ) where -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+import           Database.PostgreSQL.Store.Types+import           Database.PostgreSQL.Store.Query+import           Database.PostgreSQL.Store.Table+import           Database.PostgreSQL.Store.Entity+import           Database.PostgreSQL.Store.RowParser+import           Database.PostgreSQL.Store.Errand++import qualified Database.PostgreSQL.LibPQ as P

@@ -0,0 +1,188 @@+{-# LANGUAGE OverloadedStrings, FlexibleInstances, ScopedTypeVariables, GeneralizedNewtypeDeriving #-}++-- |+-- Module:     Database.PostgreSQL.Store.ColumnEntity+-- Copyright:  (c) Ole Krüger 2016+-- License:    BSD3+-- Maintainer: Ole Krüger <ole@vprsm.de>+module Database.PostgreSQL.Store.ColumnEntity (+	ColumnType (..),+	ColumnEntity (..)+) where++import           Data.Proxy++import           Data.Int+import           Data.Word+import           Data.Scientific+import           Numeric.Natural++import qualified Data.Aeson           as A++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.Entity+import           Database.PostgreSQL.Store.Utilities+import           Database.PostgreSQL.Store.Query.Builder++-- | Description of a column type+data ColumnType = ColumnType {+	-- | Type name+	colTypeName :: B.ByteString,++	-- | @NOT NULL@ constraint present?+	colTypeNotNull :: Bool,++	-- | Produce a check statement body when given a column name+	colTypeCheck :: Maybe (B.ByteString -> QueryBuilder)+}++-- | Classify a type which can be used as a column in a table.+class (Entity a) => ColumnEntity a where+	-- | Describe the column type+	describeColumnType :: proxy a -> ColumnType++instance (ColumnEntity a) => ColumnEntity (Maybe a) where+	describeColumnType _ =+		(describeColumnType (Proxy :: Proxy a)) {+			colTypeNotNull = False+		}++newtype PGInt2 = PGInt2 Int16+	deriving (Show, Read, Eq, Ord, Enum, Bounded, Integral, Num, Real)++instance Entity PGInt2 where+	insertEntity (PGInt2 x) =+		insertEntity x++	parseEntity =+		PGInt2 <$> parseEntity++instance ColumnEntity PGInt2 where+	describeColumnType _ =+		ColumnType "int2" True Nothing++newtype PGInt4 = PGInt4 Int32+	deriving (Show, Read, Eq, Ord, Enum, Bounded, Integral, Num, Real)++instance Entity PGInt4 where+	insertEntity (PGInt4 x) =+		insertEntity x++	parseEntity =+		PGInt4 <$> parseEntity++instance ColumnEntity PGInt4 where+	describeColumnType _ =+		ColumnType "int4" True Nothing++newtype PGInt8 = PGInt8 Int64+	deriving (Show, Read, Eq, Ord, Enum, Bounded, Integral, Num, Real)++instance Entity PGInt8 where+	insertEntity (PGInt8 x) =+		insertEntity x++	parseEntity =+		PGInt8 <$> parseEntity++instance ColumnEntity PGInt8 where+	describeColumnType _ =+		ColumnType "int8" True Nothing++-- | Select a type which can contain the given numeric type.+selectBestColumnType :: (Show a, Num a, Ord a, Bounded a) => proxy a -> ColumnType+selectBestColumnType proxy+	| -32768 <= lower && upper <= 32767 =+		ColumnType "int2" True Nothing+	| -2147483648 <= lower && upper <= 2147483647 =+		ColumnType "int4" True Nothing+	| -9223372036854775808 <= lower && upper <= 9223372036854775807 =+		ColumnType "int8" True Nothing+	| otherwise =+		ColumnType (buildByteString ("numeric(" ++ show digits ++ ",0)")) True Nothing+	where+		upper = (const maxBound :: (Bounded a) => proxy a -> a) proxy+		lower = (const minBound :: (Bounded a) => proxy a -> a) proxy+		digits = max (length (show upper)) (length (show lower))++instance ColumnEntity Bool where+	describeColumnType _ =+		ColumnType "bool" True Nothing++instance ColumnEntity Integer where+	describeColumnType _ =+		ColumnType "numeric" True Nothing++instance ColumnEntity Int where+	describeColumnType = selectBestColumnType++instance ColumnEntity Int8 where+	describeColumnType = selectBestColumnType++instance ColumnEntity Int16 where+	describeColumnType = selectBestColumnType++instance ColumnEntity Int32 where+	describeColumnType = selectBestColumnType++instance ColumnEntity Int64 where+	describeColumnType = selectBestColumnType++instance ColumnEntity Natural where+	describeColumnType _ =+		ColumnType "numeric" True Nothing++instance ColumnEntity Word where+	describeColumnType = selectBestColumnType++instance ColumnEntity Word8 where+	describeColumnType = selectBestColumnType++instance ColumnEntity Word16 where+	describeColumnType = selectBestColumnType++instance ColumnEntity Word32 where+	describeColumnType = selectBestColumnType++instance ColumnEntity Word64 where+	describeColumnType = selectBestColumnType++instance ColumnEntity Float where+	describeColumnType _ =+		ColumnType "real" True Nothing++instance ColumnEntity Double where+	describeColumnType _ =+		ColumnType "double precision" True Nothing++instance ColumnEntity Scientific where+	describeColumnType _ =+		ColumnType "numeric" True Nothing++instance ColumnEntity String where+	describeColumnType _ =+		ColumnType "text" True Nothing++instance ColumnEntity T.Text where+	describeColumnType _ =+		ColumnType "text" True Nothing++instance ColumnEntity TL.Text where+	describeColumnType _ =+		ColumnType "text" True Nothing++instance ColumnEntity B.ByteString where+	describeColumnType _ =+		ColumnType "bytea" True Nothing++instance ColumnEntity BL.ByteString where+	describeColumnType _ =+		ColumnType "bytea" True Nothing++instance ColumnEntity A.Value where+	describeColumnType _ =+		ColumnType "json" True Nothing

@@ -1,369 +0,0 @@-{-# LANGUAGE OverloadedStrings, RecordWildCards, FlexibleInstances, TemplateHaskell #-}---- |--- Module:     Database.PostgreSQL.Store.Columns--- Copyright:  (c) Ole Krüger 2015-2016--- License:    BSD3--- Maintainer: Ole Krüger <ole@vprsm.de>-module Database.PostgreSQL.Store.Columns (-	-- *-	Value (..),--	-- *-	Column (..)-) where--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.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           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 :: Oid,--		-- | Data value-		valueData :: B.ByteString-	}-	| NullValue-	deriving (Show, Eq, Ord)---- | Types which implement this type class may be used as column types.-class Column a where-	-- | Pack column value.-	pack :: a -> Value--	-- | Unpack column value.-	unpack :: Value -> Maybe a--	-- | 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       = Just <$> unpack val--	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 True = Value $(OID.bool) "true"-	pack _    = Value $(OID.bool) "false"--	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--	columnTypeName _ = "bool"--instance Column Int where-	pack n = Value $(OID.int8) (buildByteString intDec n)--	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--	columnTypeName _ = "int8"--	columnCheck _ nm =-		Just (nm ++ " >= " ++ show (minBound :: Int) ++-		      " AND " ++-		      nm ++ " <= " ++ show (maxBound :: Int))--instance Column Int8 where-	pack n = Value $(OID.int2) (buildByteString int8Dec n)--	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--	columnTypeName _ = "int2"--instance Column Int16 where-	pack n = Value $(OID.int2) (buildByteString int16Dec n)--	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--	columnTypeName _ = "int2"--instance Column Int32 where-	pack n = Value $(OID.int4) (buildByteString int32Dec n)--	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---	columnTypeName _ = "int4"--instance Column Int64 where-	pack n = Value $(OID.int8) (buildByteString int64Dec n)--	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--	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 = Value $(OID.text) (buildByteString stringUtf8 str)--	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--	columnTypeName _ = "text"--instance Column T.Text where-	pack txt = Value $(OID.text) (T.encodeUtf8 txt)--	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--	columnTypeName _ = "text"--instance Column TL.Text where-	pack txt = pack (TL.toStrict txt)--	unpack val = TL.fromStrict <$> unpack val--	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 $(OID.bytea) (encodeByteaHex bs)--	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--	columnTypeName _ = "bytea"--instance Column BL.ByteString where-	pack bs = pack (BL.toStrict bs)--	unpack val = BL.fromStrict <$> unpack val--	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-word8ToHex w =-	hex (shiftR w 4) <> hex (w .&. 15)-	where-		hex n =-			-- lel-			case n of {-				15 -> "F"; 14 -> "E"; 13 -> "D"; 12 -> "C"; 11 -> "B";-				10 -> "A"; 9  -> "9"; 8  -> "8"; 7  -> "7"; 6  -> "6";-				5  -> "5"; 4  -> "4"; 3  -> "3"; 2  -> "2"; 1  -> "1";-				_  -> "0"-			}---- | Retrieve 8-bit word from two-digit hexadecimal representation.-hexToWord8 :: B.ByteString -> Word8-hexToWord8 bs =-	case B.unpack bs of-		(a : b : _) -> shiftL (unhex a) 4 .|. unhex b-		(a : _) -> unhex a-		_ -> 0-	where-		unhex n =-			-- double lel-			case n of {-				48  ->  0; 49  ->  1; 50 ->  2; 51 ->  3; 52  ->  4;-				53  ->  5; 54  ->  6; 55 ->  7; 56 ->  8; 57  ->  9;-				65  -> 10; 66  -> 11; 67 -> 12; 68 -> 13; 69  -> 14;-				70  -> 15; 97  -> 10; 98 -> 11; 99 -> 12; 100 -> 13;-				101 -> 14; 102 -> 15; _  ->  0-			}---- | Unpack a byte array in textual representation.-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-		where-			unfoldHex "" = []-			unfoldHex bs = hexToWord8 (B.take 2 bs) : unfoldHex (B.drop 2 bs)---- | Pack textual representation of a byte array.-encodeByteaHex :: B.ByteString -> B.ByteString-encodeByteaHex bs =-	"\\x" <> B.concatMap word8ToHex bs---- | Finish the parsing process.-finishParser :: Result r -> Result r-finishParser (Partial f) = f B.empty-finishParser x = x---- | Parse a ByteString.-parseMaybe :: Parser a -> B.ByteString -> Maybe a-parseMaybe p i =-	maybeResult (finishParser (parse p i))---- | Build strict ByteString.-buildByteString :: (a -> Builder) -> a -> B.ByteString-buildByteString f x =-	BL.toStrict (toLazyByteString (f x))

@@ -0,0 +1,418 @@+{-# LANGUAGE OverloadedStrings,+             ConstraintKinds,+             DataKinds,+             DefaultSignatures,+             FlexibleContexts,+             FlexibleInstances,+             ScopedTypeVariables,+             TypeFamilies,+             TypeOperators,+             TypeSynonymInstances,+             UndecidableInstances+#-}++-- |+-- Module:     Database.PostgreSQL.Store.Entity+-- Copyright:  (c) Ole Krüger 2016+-- License:    BSD3+-- Maintainer: Ole Krüger <ole@vprsm.de>+module Database.PostgreSQL.Store.Entity (+	-- * Result and query entity+	Entity (..),++	insertGeneric,+	parseGeneric,++	-- * Helpers+	GEntityRecord (..),+	GEntityEnum (..),+	GEntity (..)+) where++import           GHC.Generics+import           GHC.TypeLits++import           Control.Applicative+import           Control.Monad++import           Data.Int+import           Data.Bits+import           Data.Word+import           Data.Scientific hiding (scientific)+import           Numeric+import           Numeric.Natural++import           Data.Bifunctor+import           Data.Proxy++import qualified Data.Aeson              as A+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.Text.Lazy.Encoding as TL++import           Data.Attoparsec.ByteString+import           Data.Attoparsec.ByteString.Char8 (signed, decimal, skipSpace, double, scientific)++import           Database.PostgreSQL.Store.Types+import           Database.PostgreSQL.Store.Utilities+import           Database.PostgreSQL.Store.Generics+import           Database.PostgreSQL.Store.Query.Builder+import           Database.PostgreSQL.Store.RowParser++import           Database.PostgreSQL.LibPQ (Oid (..), invalidOid)++-- | Generic record entity+class GEntityRecord (rec :: KRecord) where+	gInsertRecord :: Record rec -> QueryBuilder++	gParseRecord :: RowParser (Record rec)++instance (Entity typ) => GEntityRecord ('TSingle meta typ) where+	gInsertRecord (Single x) =+		insertEntity x++	gParseRecord =+		Single <$> parseEntity++instance (GEntityRecord lhs, GEntityRecord rhs) => GEntityRecord ('TCombine lhs rhs) where+	gInsertRecord (Combine lhs rhs) = do+		gInsertRecord lhs+		insertCode ","+		gInsertRecord rhs++	gParseRecord =+		Combine <$> gParseRecord <*> gParseRecord++-- | Generic enumeration entity+class GEntityEnum (enum :: KFlatSum) where+	gInsertEnum :: FlatSum enum -> QueryBuilder++	gEnumValues :: [(B.ByteString, FlatSum enum)]++instance (KnownSymbol name) => GEntityEnum ('TValue ('MetaCons name f r)) where+	gInsertEnum _ =+		insertQuote (buildByteString (symbolVal (Proxy :: Proxy name)))++	gEnumValues =+		[(buildByteString (symbolVal (Proxy :: Proxy name)), Unit)]++instance (GEntityEnum lhs, GEntityEnum rhs) => GEntityEnum ('TChoose lhs rhs) where+	gInsertEnum (ChooseLeft lhs)  = gInsertEnum lhs+	gInsertEnum (ChooseRight rhs) = gInsertEnum rhs++	gEnumValues =+		map (second ChooseLeft) gEnumValues+		++ map (second ChooseRight) gEnumValues++-- | Generic entity+class GEntity (dat :: KDataType) where+	gInsertEntity :: DataType dat -> QueryBuilder++	gParseEntity :: RowParser (DataType dat)++instance (GEntityRecord rec) => GEntity ('TRecord d c rec) where+	gInsertEntity (Record x) =+		gInsertRecord x++	gParseEntity =+		Record <$> gParseRecord++instance (GEntityEnum enum) => GEntity ('TFlatSum d enum) where+	gInsertEntity (FlatSum x) =+		gInsertEnum x++	gParseEntity =+		FlatSum <$> parseContents (`lookup` gEnumValues)++-- | Insert generic entity into the query.+insertGeneric :: (GenericEntity a, GEntity (AnalyzeEntity a)) => a -> QueryBuilder+insertGeneric x =+	gInsertEntity (fromGenericEntity x)++-- | Generic 'RowParser' for an entity.+parseGeneric :: (GenericEntity a, GEntity (AnalyzeEntity a)) => RowParser a+parseGeneric =+	toGenericEntity <$> gParseEntity++-- | An entity that is used as a parameter or result of a query.+class Entity a where+	-- | Insert an instance of @a@ into the query.+	insertEntity :: a -> QueryBuilder++	default insertEntity :: (GenericEntity a, GEntity (AnalyzeEntity a)) => a -> QueryBuilder+	insertEntity = insertGeneric++	-- | Retrieve an instance of @a@ from the result set.+	parseEntity :: RowParser a++	default parseEntity :: (GenericEntity a, GEntity (AnalyzeEntity a)) => RowParser a+	parseEntity = parseGeneric++-- | 2 result entities in sequence+instance (Entity a, Entity b) => Entity (a, b)++-- | 3 result entities in sequence+instance (Entity a, Entity b, Entity c) => Entity (a, b, c)++-- | 4 result entities in sequence+instance (Entity a, Entity b, Entity c, Entity d) => Entity (a, b, c, d)++-- | 5 result entities in sequence+instance (Entity a, Entity b, Entity c, Entity d, Entity e) => Entity (a, b, c, d, e)++-- | 6 result entities in sequence+instance (Entity a, Entity b, Entity c, Entity d, Entity e, Entity f) => Entity (a, b, c, d, e, f)++-- | 7 result entities in sequence+instance (Entity a, Entity b, Entity c, Entity d, Entity e, Entity f, Entity g) => Entity (a, b, c, d, e, f, g)++-- | 'QueryBuilder'+instance Entity QueryBuilder where+	insertEntity = id++	parseEntity = do+		colsLeft <- columnsLeft+		insertCommaSeperated <$> replicateM (fromEnum colsLeft) (insertTypedValue <$> fetchColumn)++-- | Untyped column value+instance Entity Value where+	insertEntity = insertValue++	parseEntity = parseColumn (\ (TypedValue _ mbValue) -> mbValue)++-- | Typed column value+instance Entity TypedValue where+	insertEntity = insertTypedValue++	parseEntity = fetchColumn++-- | A value which may normally not be @NULL@.+instance (Entity a) => Entity (Maybe a) where+	insertEntity Nothing  = insertTypedValue (TypedValue invalidOid Nothing)+	insertEntity (Just x) = insertEntity x++	parseEntity = do+		TypedValue _ value <- peekColumn+		case value of+			Nothing -> pure Nothing+			_       -> Just <$> parseEntity+++-- | @boolean@+instance Entity Bool where+	insertEntity input =+		insertTypedValue (TypedValue (Oid 16) (Just (Value value)))+		where value | input = "t" | otherwise = "f"++	parseEntity =+		parseContents $ \ dat ->+			Just (elem dat ["t", "1", "true", "TRUE", "y", "yes", "YES", "on", "ON"])++-- | Parse a column using the given 'Parser'.+parseContentsWith :: Parser a -> RowParser a+parseContentsWith p =+	parseContents (maybeResult . endResult . parse p)+	where+		endResult (Partial f) = f B.empty+		endResult x           = x++-- | Simplified version of 'insertTypedValue'+insertTypedValue_ :: Oid -> B.ByteString -> QueryBuilder+insertTypedValue_ typ val =+	insertTypedValue (TypedValue typ (Just (Value val)))++-- | Insert a numeric value.+insertNumericValue :: (Show a) => a -> QueryBuilder+insertNumericValue x =+	insertTypedValue_ (Oid 1700) (showByteString x)++-- | Any integer+instance Entity Integer where+	insertEntity = insertNumericValue++	parseEntity = parseContentsWith (signed decimal)++-- | Any integer+instance Entity Int where+	insertEntity = insertNumericValue++	parseEntity = parseContentsWith (signed decimal)++-- | Any integer+instance Entity Int8 where+	insertEntity = insertNumericValue++	parseEntity = parseContentsWith (signed decimal)++-- | Any integer+instance Entity Int16 where+	insertEntity = insertNumericValue++	parseEntity = parseContentsWith (signed decimal)++-- | Any integer+instance Entity Int32 where+	insertEntity = insertNumericValue++	parseEntity = parseContentsWith (signed decimal)++-- | Any integer+instance Entity Int64 where+	insertEntity = insertNumericValue++	parseEntity = parseContentsWith (signed decimal)++-- | Any unsigned integer+instance Entity Natural where+	insertEntity = insertNumericValue++	parseEntity = parseContentsWith decimal++-- | Any unsigned integer+instance Entity Word where+	insertEntity = insertNumericValue++	parseEntity = parseContentsWith decimal++-- | Any unsigned integer+instance Entity Word8 where+	insertEntity = insertNumericValue++	parseEntity = parseContentsWith decimal++-- | Any unsigned integer+instance Entity Word16 where+	insertEntity = insertNumericValue++	parseEntity = parseContentsWith decimal++-- | Any unsigned integer+instance Entity Word32 where+	insertEntity = insertNumericValue++	parseEntity = parseContentsWith decimal++-- | Any unsigned integer+instance Entity Word64 where+	insertEntity = insertNumericValue++	parseEntity = parseContentsWith decimal++-- | Any floating-point number+instance Entity Double where+	insertEntity = insertNumericValue++	parseEntity = parseContentsWith double++-- | Any floating-point number+instance Entity Float where+	insertEntity = insertNumericValue++	parseEntity = (realToFrac :: Double -> Float) <$> parseEntity++-- | Any numeric type+instance Entity Scientific where+	insertEntity x =+		insertTypedValue_ (Oid 1700) (buildByteString (formatScientific Fixed Nothing x))++	parseEntity = parseContentsWith scientific++-- | @char@, @varchar@ or @text@ - UTF-8 encoded+instance Entity String where+	insertEntity value =+		insertTypedValue_ (Oid 25) (buildByteString value)++	parseEntity = T.unpack <$> parseEntity++-- | @char@, @varchar@ or @text@ - UTF-8 encoded+instance Entity T.Text where+	insertEntity value =+		insertTypedValue_ (Oid 25) (T.encodeUtf8 value)++	parseEntity =+		parseContents (either (const Nothing) Just . T.decodeUtf8')++-- | @char@, @varchar@ or @text@ - UTF-8 encoded+instance Entity TL.Text where+	insertEntity value =+		insertEntity (TL.toStrict value)++	parseEntity =+		parseContents (either (const Nothing) Just . TL.decodeUtf8' . BL.fromStrict)++-- | @bytea@ - byte array encoded in hex format+instance Entity B.ByteString where+	insertEntity value =+		insertTypedValue_ (Oid 17) dat+		where+			dat = B.append "\\x" (B.concatMap showHex' value)++			showHex' n =+				buildByteString $ case showHex n [] of+					(a : b : _) -> [a, b]+					(a : _)     -> ['0', a]+					[]          -> "00"++	parseEntity =+		parseContentsWith (hexFormat <|> escapedFormat)+		where+			isHexChar x =+				(x >= 48 && x <= 57)     -- 0 - 9+				|| (x >= 65 && x <= 70)  -- A - Z+				|| (x >= 97 && x <= 102) -- a - z++			hexCharToWord x+				| x >= 48 && x <= 57  = x - 48+				| x >= 65 && x <= 70  = x - 55+				| x >= 97 && x <= 102 = x - 87+				| otherwise           = 0++			hexWord = do+				skipSpace+				a <- satisfy isHexChar+				b <- satisfy isHexChar++				pure (shiftL (hexCharToWord a) 4 .|. hexCharToWord b)++			hexFormat = do+				word8 92  -- \+				word8 120 -- x+				B.pack <$> many hexWord <* skipSpace++			isOctChar x = x >= 48 && x <= 55++			octCharToWord x+				| isOctChar x = x - 48+				| otherwise   = 0++			escapedWord = do+				word8 92+				a <- satisfy isOctChar+				b <- satisfy isOctChar+				c <- satisfy isOctChar++				pure (shiftL (octCharToWord a) 6 .|. shiftL (octCharToWord b) 3 .|. c)++			escapedBackslash = do+				word8 92+				word8 92++			escapedFormat =+				B.pack <$> many (escapedBackslash <|> escapedWord <|> anyWord8)++-- | @bytea@ - byte array encoded in hex format+instance Entity BL.ByteString where+	insertEntity value =+		insertEntity (BL.toStrict value)++	parseEntity = BL.fromStrict <$> parseEntity++-- | @json@ or @jsonb@+instance Entity A.Value where+	insertEntity value =+		insertTypedValue_ (Oid 114) (BL.toStrict (A.encode value))++	parseEntity = parseContents A.decodeStrict

@@ -9,44 +9,49 @@ 	-- * Errand 	ErrandError (..), 	ErrorCode (..),-	P.ExecStatus (..),- 	Errand,+ 	runErrand,  	execute,+	execute', 	query,-	query_, 	queryWith, -	-- * Result parser-	Result (..),-	Single (..)+	insert,+	insertMany,+	deleteAll,+	findAll,+	create ) where  import           Control.Monad.Trans import           Control.Monad.Except import           Control.Monad.Reader +import           Data.Proxy import           Data.Maybe import qualified Data.ByteString           as B +import           Data.Attoparsec.ByteString.Char8+ import qualified Database.PostgreSQL.LibPQ as P-import           Database.PostgreSQL.Store.Query-import           Database.PostgreSQL.Store.Result-import           Database.PostgreSQL.Store.Columns +import           Database.PostgreSQL.Store.Types+import           Database.PostgreSQL.Store.Table+import           Database.PostgreSQL.Store.Entity+import           Database.PostgreSQL.Store.RowParser+import           Database.PostgreSQL.Store.Query.Builder+ -- | Error during errand data ErrandError 	= NoResult 		-- ^ 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+	| ParseError RowError 		-- ^ Result processing failed. 	deriving (Show, Eq) @@ -72,15 +77,15 @@ 	runExceptT (runReaderT errand con)  -- | Execute a query and return the internal raw result.-execute :: Query -> Errand P.Result+execute :: Query a -> Errand P.Result execute (Query statement params) = Errand . ReaderT $ \ con -> do-	res <- ExceptT $-		transformResult <$> P.execParams con statement (map transformParam params) P.Text+	res <- ExceptT (transformResult <$> P.execParams con statement (map transformParam params) P.Text) 	status <- lift (P.resultStatus res)  	case status of-		P.CommandOk -> pure res-		P.TuplesOk  -> pure res+		P.CommandOk   -> pure res+		P.TuplesOk    -> pure res+		P.SingleTuple -> pure res  		other -> do 			(state, msg, detail, hint) <- lift $@@ -108,64 +113,94 @@  	where 		-- Turn 'Maybe P.Result' into 'Either ErrandError P.Result'-		transformResult = maybe (throwError NoResult) pure--		-- Turn 'Value' into 'Maybe (P.Oid, B.ByteString, P.Format)'-		transformParam (Value typ dat) = Just (typ, dat, P.Text)-		transformParam NullValue       = Nothing---- | 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+		transformResult =+			maybe (throwError NoResult) pure -instance (Result a, Result b, Result c) => Result (a, b, c) where-	queryResultProcessor =-		(,,) <$> queryResultProcessor <*> queryResultProcessor <*> queryResultProcessor+		-- Turn 'TypedValue' into 'Maybe (P.Oid, B.ByteString, P.Format)'+		transformParam (TypedValue typ mbValue) =+			(\ (Value value) -> (typ, value, P.Text)) <$> mbValue -instance (Result a, Result b, Result c, Result d) => Result (a, b, c, d) where-	queryResultProcessor =-		(,,,) <$> queryResultProcessor <*> queryResultProcessor <*> queryResultProcessor <*> queryResultProcessor+-- | Same as 'execute' but instead of a 'P.Result' it returns the number of affected rows.+execute' :: Query a -> Errand Int+execute' =+	countAffectedRows <=< execute -instance (Result a, Result b, Result c, Result d, Result e) => Result (a, b, c, d, e) where-	queryResultProcessor =-		(,,,,) <$> queryResultProcessor <*> queryResultProcessor <*> queryResultProcessor <*> queryResultProcessor <*> queryResultProcessor+-- | Execute a query and process its result set.+query :: (Entity a) => Query a -> Errand [a]+query qry =+	queryWith qry parseEntity -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+-- | Execute a query and process its result set using the provided 'RowParser'.+queryWith :: Query a -> RowParser a -> Errand [a]+queryWith qry parser = do+	result <- execute qry+	Errand (lift (withExceptT ParseError (parseResult result parser))) -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+-- | Counts the rows that have been affected by a query.+countAffectedRows :: P.Result -> Errand Int+countAffectedRows res = do+	fmap (\ numTuples -> fromMaybe 0 (numTuples >>= maybeResult . endResult . parse decimal))+	     (liftIO (P.cmdTuples res))+	where+		endResult (Partial f) = f B.empty+		endResult x           = x --- | Execute a query and process its result set.-query :: (Result a) => Query -> Errand [a]-query qry =-	queryWith qry queryResultProcessor+-- | Insert a row into a 'Table'.+insert :: (TableEntity a) => a -> Errand Bool+insert row = do+	fmap (> 0) . execute' $ buildQuery $ do+		insertCode "INSERT INTO "+		insertName name+		insertCode "("+		insertCommaSeperated (map (\ (Column colName _) -> insertName colName) cols)+		insertCode ") VALUES ("+		insertEntity row+		insertCode ")"+	where+		Table name cols =+			describeTableType ((const Proxy :: a -> Proxy a) row) --- | Execute a query and dismiss its result.-query_ :: Query -> Errand ()-query_ qry =-	() <$ execute qry+-- | Insert many rows into a 'Table'.+insertMany :: (TableEntity a) => [a] -> Errand Int+insertMany [] = pure 0+insertMany rows =+	execute' $ buildQuery $ do+		insertCode "INSERT INTO "+		insertName name+		insertCode "("+		insertCommaSeperated (map (\ (Column colName _) -> insertName colName) cols)+		insertCode ") VALUES "+		insertCommaSeperated (map insertRowValue rows)+	where+		Table name cols =+			describeTableType ((const Proxy :: [a] -> Proxy a) rows) --- | 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)))+		insertRowValue row = do+			insertCode "("+			insertEntity row+			insertCode ")" --- | Helper type to capture an single column.-newtype Single a = Single { fromSingle :: a }-	deriving (Eq, Ord)+-- | Delete all rows of a 'Table'.+deleteAll :: (TableEntity a) => proxy a -> Errand Int+deleteAll proxy =+	execute' $ buildQuery $ do+		insertCode "DELETE FROM "+		insertName (tableName (describeTableType proxy)) -instance (Show a) => Show (Single a) where-	show = show . fromSingle+-- | Find every row of a 'Table'.+findAll :: (TableEntity a) => Errand [a]+findAll =+	query (findAllQuery Proxy)+	where+		findAllQuery :: (TableEntity a) => Proxy a -> Query a+		findAllQuery proxy =+			buildQuery $ do+				insertCode "SELECT "+				insertColumns (describeTableType proxy)+				insertCode " FROM "+				insertName (tableName (describeTableType proxy)) -instance (Column a) => Result (Single a) where-	queryResultProcessor = Single <$> unpackColumn+-- | Create the given 'Table' type.+create :: (TableEntity a) => proxy a -> Errand ()+create proxy =+	() <$ execute (buildQuery (buildTableSchema (describeTableType proxy)))

@@ -0,0 +1,306 @@+{-# LANGUAGE ConstraintKinds,+             DataKinds,+             FlexibleContexts,+             FlexibleInstances,+             GADTs,+             StandaloneDeriving,+             TypeFamilies,+             TypeOperators,+             TypeSynonymInstances,+             UndecidableInstances+#-}++-- |+-- Module:     Database.PostgreSQL.Store.Generics+-- Copyright:  (c) Ole Krüger 2016+-- License:    BSD3+-- Maintainer: Ole Krüger <ole@vprsm.de>+module Database.PostgreSQL.Store.Generics (+	-- * Generic Entity+	EntityDataType,+	GenericEntity,++	toGenericEntity,+	fromGenericEntity,+++	-- * Type-Level Information+	KRecord (..),+	KFlatSum (..),+	KDataType (..),++	-- * Mapper classes+	GRecord (..),+	GFlatSum (..),+	GDataType (..),++	Record (..),+	FlatSum (..),+	DataType (..),++	-- * Analyzers+	AnalyzeRecordRep,+	AnalyzeFlatSumRep,+	AnalyzeDataType,++	AnalyzeEntity+) where++import GHC.Generics+import GHC.TypeLits++import Data.Kind++-- | Information about a record+data KRecord+	= TCombine KRecord KRecord+		-- ^ Combination of two records+	| TSingle Meta Type+		-- ^ Single element with meta information and type++-- | Mappings between a 'Generic' representation and our 'KRecord'-based representation+class GRecord (rec :: KRecord) where+	-- | 'Generic' representation+	type RecordRep rec :: * -> *++	-- | 'KRecord'-based representation+	data Record rec++	-- | From 'Generic' representation+	toRecord :: RecordRep rec x -> Record rec++	-- | To 'Generic' representation+	fromRecord :: Record rec -> RecordRep rec x++-- | Single record+instance GRecord ('TSingle meta typ) where+	type RecordRep ('TSingle meta typ) = S1 meta (Rec0 typ)++	data Record ('TSingle meta typ) = Single typ++	toRecord (M1 (K1 x)) = Single x++	fromRecord (Single x) = M1 (K1 x)++deriving instance (Show typ) => Show (Record ('TSingle meta typ))++-- | Combination of records+instance (GRecord lhs, GRecord rhs) => GRecord ('TCombine lhs rhs) where+	type RecordRep ('TCombine lhs rhs) = RecordRep lhs :*: RecordRep rhs++	data Record ('TCombine lhs rhs) = Combine (Record lhs) (Record rhs)++	toRecord (lhs :*: rhs) = Combine (toRecord lhs) (toRecord rhs)++	fromRecord (Combine lhs rhs) = fromRecord lhs :*: fromRecord rhs++deriving instance (Show (Record lhs), Show (Record rhs)) => Show (Record ('TCombine lhs rhs))++-- | Analyze the 'Generic' representation of the selectors. Make sure it has 1 or more fields. Then+-- transform it into a 'KRecord'.+type family AnalyzeRecordRep org (sel :: * -> *) :: KRecord where+	-- Single field+	AnalyzeRecordRep org (S1 meta (Rec0 typ)) =+		'TSingle meta typ++	-- Multiple fields+	AnalyzeRecordRep org (lhs :*: rhs) =+		'TCombine (AnalyzeRecordRep org lhs) (AnalyzeRecordRep org rhs)++	-- Missing field(s)+	AnalyzeRecordRep org U1 =+		TypeError ('Text "Given type "+		           ':<>: 'ShowType org+		           ':<>: 'Text " has one constructor, therefore that constructor must have \+		                       \at least one field")++	-- Something else+	AnalyzeRecordRep org other =+		TypeError ('Text "Given type "+		           ':<>: 'ShowType org+		           ':<>: 'Text " has a constructor with an invalid selector"+		           ':$$: 'ShowType other)++-- | Information about the constructors of an enumeration+data KFlatSum+	= TChoose KFlatSum KFlatSum+		-- ^ Combination of values+	| TValue Meta+		-- ^ Single value of the enumeration++-- | Mappings between a 'Generic' representation and our 'KFlatSum'-based representation+class GFlatSum (enum :: KFlatSum) where+	-- | 'Generic' representation+	type FlatSumRep enum :: * -> *++	-- | 'KFlatSum'-based representation+	data FlatSum enum++	-- | From 'Generic' representation+	toFlatSum :: FlatSumRep enum x -> FlatSum enum++	-- | To 'Generic' representation+	fromFlatSum :: FlatSum enum -> FlatSumRep enum x++-- | Single constructor+instance GFlatSum ('TValue meta) where+	type FlatSumRep ('TValue meta) = C1 meta U1++	data FlatSum ('TValue meta) = Unit++	toFlatSum (M1 U1) = Unit++	fromFlatSum Unit = M1 U1++deriving instance Show (FlatSum ('TValue meta))++-- | Combination of multiple constructors+instance (GFlatSum lhs, GFlatSum rhs) => GFlatSum ('TChoose lhs rhs) where+	type FlatSumRep ('TChoose lhs rhs) = FlatSumRep lhs :+: FlatSumRep rhs++	data FlatSum ('TChoose lhs rhs) = ChooseLeft (FlatSum lhs) | ChooseRight (FlatSum rhs)++	toFlatSum (L1 lhs) = ChooseLeft (toFlatSum lhs)+	toFlatSum (R1 rhs) = ChooseRight (toFlatSum rhs)++	fromFlatSum (ChooseLeft lhs)  = L1 (fromFlatSum lhs)+	fromFlatSum (ChooseRight rhs) = R1 (fromFlatSum rhs)++deriving instance (Show (FlatSum lhs), Show (FlatSum rhs)) => Show (FlatSum ('TChoose lhs rhs))++-- | Analyze the 'Generic' representation of constructors. Make sure every constructor has zero+-- fields. Then transform it into a 'KFlatSum'.+type family AnalyzeFlatSumRep org (cons :: * -> *) :: KFlatSum where+	-- Constructor without record selector+	AnalyzeFlatSumRep org (C1 meta U1) =+		'TValue meta++	-- Constructor with a record selector is invalid+	AnalyzeFlatSumRep org (C1 meta1 (S1 meta2 rec)) =+		TypeError ('Text "Given type "+		           ':<>: 'ShowType org+		           ':<>: 'Text " has multiple constructors, therefore these constructors must have \+		                       \no fields")++	-- Constructor with a record selector is invalid+	AnalyzeFlatSumRep org (C1 meta1 (lhs :*: rhs)) =+		TypeError ('Text "Given type "+		           ':<>: 'ShowType org+		           ':<>: 'Text " has multiple constructors, therefore these constructors must have \+		                       \no fields")++	-- More constructors+	AnalyzeFlatSumRep org (lhs :+: rhs) =+		'TChoose (AnalyzeFlatSumRep org lhs) (AnalyzeFlatSumRep org rhs)++	-- Something else+	AnalyzeFlatSumRep org other =+		TypeError ('Text "Given type "+		           ':<>: 'ShowType org+		           ':<>: 'Text " has an invalid constructor"+		           ':$$: 'ShowType other)++-- | Information about a data type+data KDataType+	= TRecord Meta Meta KRecord+		-- ^ Record+	| TFlatSum Meta KFlatSum+		-- ^ Enumeration++-- | Mappings between a 'Generic' representation and our 'KDataType'-based representation+class GDataType (dat :: KDataType) where+	-- | 'Generic' representation+	type DataTypeRep dat :: * -> *++	-- | 'KDataType'-based representation+	data DataType dat++	-- | From 'Generic' representation+	toDataType :: DataTypeRep dat x -> DataType dat++	-- | To 'Generic' representation+	fromDataType :: DataType dat -> DataTypeRep dat x++-- | With single constructor+instance (GRecord rec) => GDataType ('TRecord d c rec) where+	type DataTypeRep ('TRecord d c rec) = D1 d (C1 c (RecordRep rec))++	data DataType ('TRecord d c rec) = Record (Record rec)++	toDataType (M1 (M1 rec)) = Record (toRecord rec)++	fromDataType (Record rec) = M1 (M1 (fromRecord rec))++deriving instance (Show (Record rec)) => Show (DataType ('TRecord d c rec))++-- | With multiple constructors+instance (GFlatSum enum) => GDataType ('TFlatSum d enum) where+	type DataTypeRep ('TFlatSum d enum) = D1 d (FlatSumRep enum)++	data DataType ('TFlatSum d enum) = FlatSum (FlatSum enum)++	toDataType (M1 enum) = FlatSum (toFlatSum enum)++	fromDataType (FlatSum flatSum) = M1 (fromFlatSum flatSum)++deriving instance (Show (FlatSum enum)) => Show (DataType ('TFlatSum d enum))++-- | Analyze the 'Generic' representation of a data type. If only one constructor exists, further+-- analyzing is delegated to 'AnalyzeRecordRep'. When two or more exist, analyzing is performed by+-- 'AnalyzeFlatSumRep'. The results are gather in a 'KDataType' instance.+type family AnalyzeDataType org (dat :: * -> *) :: KDataType where+	-- Single constructor+	AnalyzeDataType org (D1 meta1 (C1 meta2 sel)) =+		'TRecord meta1 meta2 (AnalyzeRecordRep org sel)++	-- Multiple constructors+	AnalyzeDataType org (D1 meta (lhs :+: rhs)) =+		'TFlatSum meta (AnalyzeFlatSumRep org (lhs :+: rhs))++	-- Missing constructor(s)+	AnalyzeDataType org (D1 meta V1) =+		TypeError ('Text "Given type "+		           ':<>: 'ShowType org+		           ':<>: 'Text " must have a constructor")++	-- Data type with constructor(s) that does not match the given patterns+	AnalyzeDataType org (D1 meta other) =+		TypeError ('Text "Given type "+		           ':<>: 'ShowType org+		           ':<>: 'Text " has an invalid constructor"+		           ':$$: 'ShowType other)++	-- Something else+	AnalyzeDataType org other =+		TypeError ('Text "Given type "+		           ':<>: 'ShowType org+		           ':<>: 'Text " is not a valid data type"+		           ':$$: 'ShowType other)++-- | Analyze the 'Generic' representation of a type, in order to generate its 'KDataType' instance.+type AnalyzeEntity a = AnalyzeDataType a (Rep a)++-- | Analyze the 'Generic' representation of a type to figure out which 'DataType' it needs.+type EntityDataType a = DataType (AnalyzeEntity a)++-- | Make sure @a@ has a safe generic representation. Types that qualify implement 'Generic' and+-- fulfill one of the following criteria:+--+--  * single constructor with 1 or more fields+--  * multiple constructors with no fields+--+-- This constraint is mostly utilized to give the user more information about why their type has+-- been rejected.+type GenericEntity a = (Generic a,+                        GDataType (AnalyzeEntity a),+                        DataTypeRep (AnalyzeEntity a) ~ Rep a)++-- | Convert to entity representation.+fromGenericEntity :: (GenericEntity a) => a -> EntityDataType a+fromGenericEntity =+	toDataType . from++-- | Build from entity representation.+toGenericEntity :: (GenericEntity a) => EntityDataType a -> a+toGenericEntity =+	to . fromDataType

@@ -1,91 +0,0 @@-{-# 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,444 +1,24 @@-{-# LANGUAGE QuasiQuotes, TemplateHaskell, BangPatterns,-             GeneralizedNewtypeDeriving, MultiParamTypeClasses, FunctionalDependencies,-             FlexibleInstances, FlexibleContexts, TypeFamilies #-}- -- | -- Module:     Database.PostgreSQL.Store.Query--- Copyright:  (c) Ole Krüger 2015-2016+-- Copyright:  (c) Ole Krüger 2016 -- License:    BSD3 -- Maintainer: Ole Krüger <ole@vprsm.de>+--+-- This module acts solely as a re-export unit. module Database.PostgreSQL.Store.Query (-	-- * Query-	Query (..),-	SelectorElement (..),-	QueryTable (..),-	pgsq,-	pgss,--	-- * Helpers-	quoteIdentifier,+	-- * Exported modules+	module Database.PostgreSQL.Store.Query.Builder,+	module Database.PostgreSQL.Store.Query.TH, -	-- * Query builder-	QueryCode,-	QueryBuildable,-	QueryBuilder,-	runQueryBuilder,-	writeCode,-	writeStringCode,-	writeIdentifier,-	writeAbsIdentifier,-	writeParam,-	writeColumn,-	intercalateBuilder+	-- * Utilities+	castQuery ) where -import           Language.Haskell.TH-import           Language.Haskell.TH.Quote--import           Control.Applicative-import           Control.Monad.State.Strict--import           Data.List-import           Data.Proxy-import           Data.Monoid-import           Data.String-import qualified Data.Text       as T-import qualified Data.ByteString as B--import           Data.Char-import           Data.Attoparsec.Text--import           Database.PostgreSQL.Store.Columns---- | 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------ Use the 'pgsq' quasi-quoter to conveniently create queries.-data Query = Query {-	-- | Statement-	queryStatement :: !B.ByteString,--	-- | Parameters-	queryParams :: ![Value]-} deriving (Show, Eq, Ord)---- | @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.------ Some syntax definitions that might be useful later on:------ > TypeName          ::= UpperAlpha {AlphaNumeric | '_'}--- > Name              ::= (Alpha | '_') {AlphaNumeric | '_'}--- > QualifiedTypeName ::= {TypeName '.'} TypeName------ @Alpha@ includes all alphabetical characters; @UpperAlpha@ includes all upper-case alphabetical--- characters; @AlphaNumeric@ includes all alpha-numeric characters.------ = Embed values--- You can embed values whose types implement 'Column'.------ > ValueExp ::= '$' Name------ > magicNumber :: Int--- > magicNumber = 1337--- >--- > myQuery :: Query--- > myQuery =--- >     [pgsq| SELECT * FROM table t WHERE t.column1 > $magicNumber AND t.column2 < $otherNumber |]--- >     where otherNumber = magicNumber * 2------ @$magicNumber@ and @$otherNumber@ are references to values @magicNumber@ and @otherNumber@.------ The quasi-quoter will generate a 'Query' expression similar to the following.------ > Query "SELECT * FROM table t WHERE t.column1 > $1 AND t.column2 < $2"--- >       [pack magicNumber, pack otherNumber]------ = 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.------ > TableNameExp ::= '@' QualifiedTypeName------ 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 @ABS(A)@.------ > instance QueryTable YourType where--- >     tableName _ = "YourTable"--- >--- > myQuery :: Query--- > myQuery =--- >     [pgsq| SELECT * FROM @YourType WHERE @YourType.column = 1337 |]------ The table name will be inlined which results in the following.------ > Query "SELECT * FROM \"YourTable\" WHERE \"YourTable\".column = 1337" []------ = 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.------ > TableIdentExp ::= '&' TypeName------ @&@ 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)@.------ > instance QueryTable YourType where--- >     tableName _   = "YourTable"--- >     tableIDName _ = "id"--- >--- > listIDs :: Query--- > listIDs =--- >     [pgsq| SELECT &YourType FROM @YourType |]------ @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 |]------ = 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 {-		quoteExp  = parseStoreQueryE,-		quotePat  = const (fail "Cannot use 'pgsq' in pattern"),-		quoteType = const (fail "Cannot use 'pgsq' in type"),-		quoteDec  = const (fail "Cannot use 'pgsq' in declaration")-	}---- | 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)--		Right xs -> do-			[e| mconcat $(listE (runQueryBuilder_ (mapM_ reduceSegment xs))) |]---- | 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")-	}---- | Internal state for every builder-data BuilderState s p = BuilderState s Word [p]---- |-class QueryCode s where-	type Code s--	appendCode :: s -> Code s -> s--	appendStringCode :: s -> String -> s--instance QueryCode B.ByteString where-	type Code B.ByteString = B.ByteString--	appendCode = B.append--	appendStringCode bs str = bs <> fromString str--instance QueryCode [Q Exp] where-	type Code [Q Exp] = Q Exp--	appendCode segments exp = segments ++ [exp]--	appendStringCode segments str = appendCode segments [e| fromString $(stringE str) |]--instance QueryCode String where-	type Code String = String--	appendCode segments code = segments ++ code--	appendStringCode = appendCode---- | Can build @o@ using @s@ and @[p]@.-class QueryBuildable s p o | s p -> o where-	buildQuery :: s -> [p] -> o--instance QueryBuildable B.ByteString Value Query where-	buildQuery = Query--instance QueryBuildable String (Q Exp) (Q Exp) where-	buildQuery code params =-		[e| Query (fromString $(stringE code)) $(listE params) |]--instance QueryBuildable [Q Exp] (Q Exp) (Q Exp) where-	buildQuery codeSegments params =-		[e| Query (B.concat $(listE codeSegments)) $(listE params) |]---- | Query builder-type QueryBuilder s p = State (BuilderState s p) ()---- | 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 [])---- | 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 [])---- | Write code.-writeCode :: (QueryCode s) => Code s -> QueryBuilder s p-writeCode code =-	modify $ \ (BuilderState stmt idx params) ->-		BuilderState (appendCode stmt code) idx params---- | Write string code.-writeStringCode :: (QueryCode s) => String -> QueryBuilder s p-writeStringCode code =-	modify $ \ (BuilderState stmt idx params) ->-		BuilderState (appendStringCode stmt code) idx params---- | Add an identifier.-writeIdentifier :: (QueryCode s) => String -> QueryBuilder s p-writeIdentifier name =-	writeStringCode (quoteIdentifier name)---- | 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)+import Database.PostgreSQL.Store.Types+import Database.PostgreSQL.Store.Query.Builder+import Database.PostgreSQL.Store.Query.TH --- | Do something between other builders.-intercalateBuilder :: QueryBuilder s p -> [QueryBuilder s p] -> QueryBuilder s p-intercalateBuilder x xs =-	sequence_ (intersperse x xs)+-- | Cast the query's result type.+castQuery :: Query a -> Query b+castQuery (Query s p) =+	Query s p

@@ -0,0 +1,131 @@+{-# LANGUAGE OverloadedStrings, RecordWildCards, TypeSynonymInstances, FlexibleInstances #-}++-- |+-- Module:     Database.PostgreSQL.Store.Query.Builder+-- Copyright:  (c) Ole Krüger 2016+-- License:    BSD3+-- Maintainer: Ole Krüger <ole@vprsm.de>+module Database.PostgreSQL.Store.Query.Builder (+	-- * Query Builder+	QueryBuilder,+	insertCode,+	insertTypedValue,+	insertValue,+	insertValue',+	insertQuote,+	insertName,++	insertCommaSeperated,++	-- * Generalized Building+	FromQueryBuilder (..)+) where++import           Control.Monad.State.Strict++import           Data.List+import qualified Data.ByteString           as B++import           Database.PostgreSQL.LibPQ (invalidOid)++import           Database.PostgreSQL.Store.Types+import           Database.PostgreSQL.Store.Utilities++-- | Internal builder state+data BuilderState = BuilderState {+	queryCode   :: B.ByteString,+	queryIndex  :: Word,+	queryValues :: [TypedValue]+}++-- | Query builder+type QueryBuilder = State BuilderState ()++-- | Insert a piece of SQL.+insertCode :: B.ByteString -> QueryBuilder+insertCode code =+	modify (\ state -> state {queryCode = B.append (queryCode state) code})++-- | Insert a parameter placeholder into the code and attach the typed value to the query.+insertTypedValue :: TypedValue -> QueryBuilder+insertTypedValue typedValue =+	modify $ \ BuilderState {..} ->+		BuilderState {+			queryCode = B.concat [queryCode, B.singleton 36, showByteString queryIndex],+			queryIndex = queryIndex + 1,+			queryValues = queryValues ++ [typedValue]+		}++-- | Same as 'insertTypedValue' but untyped.+insertValue :: Value -> QueryBuilder+insertValue value =+	insertTypedValue (TypedValue invalidOid (Just value))++-- | Extension of 'insertValue' which will add a type hint to the parameter placeholder.+insertValue' :: B.ByteString -> Value -> QueryBuilder+insertValue' typ value = do+	insertCode "("+	insertValue value+	insertCode "::"+	insertCode typ+	insertCode ")"++-- | Insert a quote into the code.+insertQuote :: B.ByteString -> QueryBuilder+insertQuote contents =+	insertCode (B.concat [B.singleton 39, -- '+	                      B.concatMap replaceDelim contents,+	                      B.singleton 39])+	where+		replaceDelim 39 = B.pack [39, 39]+		replaceDelim x  = B.singleton x++-- | Join several builders into a comma-seperated list.+insertCommaSeperated :: [QueryBuilder] -> QueryBuilder+insertCommaSeperated bs =+	sequence_ (intersperse (insertCode ",") bs)++-- | Insert a name into the code. It will be surrounded by double quotes if necessary.+insertName :: B.ByteString -> QueryBuilder+insertName name =+	if isAllowed then+		insertCode name+	else+		insertCode (B.concat [B.singleton 34, -- "+		                      B.intercalate (B.pack [34, 34]) (B.split 34 name),+		                      B.singleton 34])+	where+		isAllowedHead b =+			(b >= 97 && b <= 122)    -- 'a' to 'z'+			|| (b >= 65 && b <= 90)  -- 'A' to 'Z'+			|| b == 95               -- '_'++		isAllowedBody b =+			isAllowedHead b+			|| (b >= 48 && b <= 57)  -- '0' to '9'++		isAllowed =+			case B.uncons name of+				Nothing -> True+				Just (h, b) -> isAllowedHead h && B.all isAllowedBody b++-- | @a@ can be instantiated using the query builder.+class FromQueryBuilder a where+	buildQuery :: QueryBuilder -> a++instance FromQueryBuilder QueryBuilder where+	buildQuery = id++instance FromQueryBuilder B.ByteString where+	buildQuery builder =+		queryCode (execState builder (BuilderState B.empty 1 []))++instance FromQueryBuilder (B.ByteString, [TypedValue]) where+	buildQuery builder =+		(code, values)+		where BuilderState code _ values = execState builder (BuilderState B.empty 1 [])++instance FromQueryBuilder (Query a) where+	buildQuery builder =+		Query code values+		where BuilderState code _ values = execState builder (BuilderState B.empty 1 [])

@@ -0,0 +1,230 @@+{-# LANGUAGE TemplateHaskell, OverloadedStrings #-}++-- |+-- Module:     Database.PostgreSQL.Store.Query.TH+-- Copyright:  (c) Ole Krüger 2016+-- License:    BSD3+-- Maintainer: Ole Krüger <ole@vprsm.de>+module Database.PostgreSQL.Store.Query.TH (+	-- * Template Haskell+	parseQuery,+	pgsq+) where++import           Language.Haskell.TH+import           Language.Haskell.TH.Quote+import           Language.Haskell.Meta.Parse++import           Control.Applicative++import           Data.List+import           Data.Proxy+import           Data.Char+import           Data.Attoparsec.Text+import qualified Data.ByteString                    as B+import qualified Blaze.ByteString.Builder           as B+import qualified Blaze.ByteString.Builder.Char.Utf8 as B+import qualified Data.Text                          as T++import           Database.PostgreSQL.Store.Utilities+import           Database.PostgreSQL.Store.Entity+import           Database.PostgreSQL.Store.Table+import           Database.PostgreSQL.Store.Query.Builder++-- | Name+valueName :: Parser String+valueName =+	(:) <$> (letter <|> char '_') <*> many (satisfy isAlphaNum <|> char '_' <|> char '\'')++-- | Type name+typeName :: Parser String+typeName =+	(:) <$> satisfy isUpper <*> many (satisfy isAlphaNum <|> char '_' <|> char '\'')++-- | Qualified type name+qualifiedTypeName :: Parser String+qualifiedTypeName =+	intercalate "." <$> sepBy1 typeName (char '.')++-- | Query segment+data QuerySegment+	= QueryEntity String+	| QueryEntityCode String+	| QueryQuote Char String+	| QueryOther String+	| QueryTable String+	| QuerySelector String+	| QuerySelectorAlias String String+	-- QueryIdentifier String+	deriving (Show, Eq, Ord)++-- | Table+tableSegment :: Parser QuerySegment+tableSegment = do+	char '@'+	QueryTable <$> qualifiedTypeName++-- | Selector+selectorSegment :: Parser QuerySegment+selectorSegment = do+	char '#'+	QuerySelector <$> qualifiedTypeName++-- | Selector alias+selectorAliasSegment :: Parser QuerySegment+selectorAliasSegment = do+	char '#'+	QuerySelectorAlias <$> qualifiedTypeName+	                   <*  char '('+	                   <*> valueName+	                   <*  char ')'++-- -- | Identifier+-- identifierSegment :: Parser QuerySegment+-- identifierSegment = do+-- 	char '&'+-- 	QueryIdentifier <$> qualifiedTypeName++-- | Entity+entityNameSegment :: Parser QuerySegment+entityNameSegment = do+	char '$'+	QueryEntity <$> valueName++-- | Entity code+entityCodeSegment :: Parser QuerySegment+entityCodeSegment =+	QueryEntityCode <$> (string "$(" *> insideCode <* char ')')+	where+		insideCode =+			concat <$> many (choice [bracedCode,+			                         quoteCode '\'',+			                         quoteCode '\"',+			                         some (satisfy (notInClass "\"'()"))])++		bracedCode =+			char '(' *> fmap (\ code -> '(' : code ++ ")") insideCode <* char ')'++		quoteCode delim = do+			char delim+			cnt <- many (choice [escapedDelim delim, notDelim delim])+			char delim+			pure (delim : concat cnt ++ [delim])++		escapedDelim delim = do+			char '\\'+			char delim+			pure ['\\', delim]++		notDelim delim =+			(: []) <$> notChar delim++-- | Quotation+quoteSegment :: Char -> Parser QuerySegment+quoteSegment delim = do+	char delim+	cnt <- concat <$> many (choice [escapedDelim, notDelim])+	char delim+	pure (QueryQuote delim cnt)+	where+		escapedDelim = char delim >> char delim >> pure [delim, delim]+		notDelim = (: []) <$> notChar delim++-- | Uninterpreted segment+otherSegment :: Parser QuerySegment+otherSegment =+	QueryOther <$> some (satisfy (notInClass "\"'@#$"))+	-- QueryOther <$> some (satisfy (notInClass "\"'@&#$"))++-- | Segment that is part of the query+querySegment :: Parser QuerySegment+querySegment =+	choice [quoteSegment '\'',+	        quoteSegment '"',+	        tableSegment,+	        selectorAliasSegment,+	        selectorSegment,+	        -- identifierSegment,+	        entityCodeSegment,+	        entityNameSegment,+	        otherSegment]++-- | Pack 'String' code into a 'ByteString'.+packCode :: String -> B.ByteString+packCode code =+	B.toByteString (B.fromString code)++-- | Translate a "QuerySegment" to an expression.+translateSegment :: QuerySegment -> Q Exp+translateSegment segment =+	case segment of+		QueryTable stringName -> do+			mbTypeName <- lookupTypeName stringName+			case mbTypeName of+				Nothing -> fail ("'" ++ stringName ++ "' does not refer to a type")+				Just typ ->+					[e| insertName (tableName (describeTableType (Proxy :: Proxy $(conT typ)))) |]++		QuerySelector stringName -> do+			mbTypeName <- lookupTypeName stringName+			case mbTypeName of+				Nothing -> fail ("'" ++ stringName ++ "' does not refer to a type")+				Just typ ->+					[e| insertColumns (describeTableType (Proxy :: Proxy $(conT typ))) |]++		QuerySelectorAlias stringName aliasName -> do+			mbTypeName <- lookupTypeName stringName+			case mbTypeName of+				Nothing -> fail ("'" ++ stringName ++ "' does not refer to a type")+				Just typ ->+					[e| insertColumnsOn (describeTableType (Proxy :: Proxy $(conT typ)))+					                    $(liftByteString (buildByteString aliasName)) |]++		-- QueryIdentifier stringName -> do+		-- 	mbTypeName <- lookupTypeName stringName+		-- 	case mbTypeName of+		-- 		Nothing -> fail ("'" ++ stringName ++ "' does not refer to a type")+		-- 		Just typ ->+		-- 			[e| insertTableIdentColumnName (Proxy :: Proxy $(conT typ)) |]++		QueryEntity stringName -> do+			mbValueName <- lookupValueName stringName+			case mbValueName of+				Nothing -> fail ("'" ++ stringName ++ "' does not refer to a value")+				Just name ->+					[e| insertEntity $(varE name) |]++		QueryEntityCode code ->+			case parseExp code of+				Left msg -> fail ("Error in code " ++ show code ++ ": " ++ msg)+				Right expr ->+					[e| insertEntity $(pure expr) |]++		QueryQuote delim code ->+			[e| insertCode $(liftByteString (packCode (delim : code ++ [delim]))) |]++		QueryOther code ->+			[e| insertCode $(liftByteString (packCode code)) |]++-- | Parse a query string in order to produce a 'QueryBuilder' expression.+parseQuery :: String -> Q Exp+parseQuery code =+	case parseOnly (many querySegment <* endOfInput) (T.strip (T.pack code)) of+		Left msg ->+			fail ("Query parser failed: " ++ msg)++		Right [] ->+			[e| buildQuery (pure ()) |]++		Right segments ->+			[e| buildQuery $(DoE . map NoBindS <$> mapM translateSegment segments) |]++-- | Generate queries conveniently. See 'BuildQuery' to find out which types can be produced.+pgsq :: QuasiQuoter+pgsq =+	QuasiQuoter {+		quoteExp  = parseQuery,+		quotePat  = const (fail "Cannot use 'pgsq' in pattern"),+		quoteType = const (fail "Cannot use 'pgsq' in type"),+		quoteDec  = const (fail "Cannot use 'pgsq' in declaration")+	}

@@ -1,82 +0,0 @@-{-# 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,-	processResult,-	processOneResult,--	skipColumn,-	unpackColumn-) where--import           Control.Monad-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-	= 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-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)---- | Move cursor to the next column.-skipColumn :: ResultProcessor ()-skipColumn =-	ResultProcessor (modify (+ 1))---- | 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--	-- Make sure we're not trying to unpack a non-existing column-	when (col >= numCol) (throwError (TooFewColumnsError numCol))--	-- Retrieve column-specific information-	(typ, mbData) <- liftIO $-		(,) <$> P.ftype res col <*> P.getvalue' res row col--	-- 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)---- | 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)--	-- Iterate over each row number and run the row processor-	forM [0 .. rows - 1] $ \ row ->-		runReaderT (evalStateT proc 0) (res, row, cols)---- | 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)--	if rows > 0 then-		Just <$> runReaderT (evalStateT proc 0) (res, 0, cols)-	else-		pure Nothing

@@ -0,0 +1,175 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++-- |+-- Module:     Database.PostgreSQL.Store.RowParser+-- Copyright:  (c) Ole Krüger 2016+-- License:    BSD3+-- Maintainer: Ole Krüger <ole@vprsm.de>+module Database.PostgreSQL.Store.RowParser (+	-- * Row Parser+	RowParser,+	RowErrorLocation (..),+	RowErrorDetail (..),+	RowError (..),++	rowNumber,+	columnNumber,+	columnsLeft,++	fetchColumn,+	peekColumn,+	parseColumn,++	peekContents,+	fetchContents,+	parseContents,++	skipColumn,++	-- * Result Parser+	parseResult+) where++import           Control.Monad+import           Control.Monad.Except+import           Control.Monad.Reader+import           Control.Monad.State.Strict++import qualified Data.ByteString           as B++import qualified Database.PostgreSQL.LibPQ as P+import           Database.PostgreSQL.Store.Types++-- | Location of an error+data RowErrorLocation = RowErrorLocation P.Column P.Row+	deriving (Show, Eq, Ord)++-- | Errors that occur during row parsing+data RowErrorDetail+	= TooFewColumns+		-- ^ Underlying 'RowParser' wants more columns than are currently present.+	| ColumnRejected TypedValue+		-- ^ A column value could not be parsed.+	| ContentsRejected (Maybe B.ByteString)+		-- ^ The contents of a column could not be parsed.+	deriving (Show, Eq, Ord)++-- | An error that occured when parsing a row.+data RowError = RowError RowErrorLocation RowErrorDetail+	deriving (Show, Eq, Ord)++-- | Static result information+data ResultInfo = ResultInfo P.Result -- Result to operate on+                             P.Column -- Total number of columns++-- | Static row information+data RowInput = RowInput ResultInfo -- Result info+                         P.Row      -- Current row to operate on++-- | Row parser+newtype RowParser a =+	RowParser (ReaderT RowInput (StateT P.Column (ExceptT RowError IO)) a)+	deriving (Functor, Applicative, Monad, MonadError RowError)++-- | Parse a single row.+parseRow :: RowParser a -> RowInput -> ExceptT RowError IO a+parseRow (RowParser parser) rowInfo =+	evalStateT (runReaderT parser rowInfo) (P.Col 0)++-- | Retrieve the current row number.+rowNumber :: RowParser P.Row+rowNumber = RowParser (asks (\ (RowInput _ row) -> row))++-- | Retrieve the current column number.+columnNumber :: RowParser P.Column+columnNumber = RowParser get++-- | Retrieve the number of columns left.+columnsLeft :: RowParser P.Column+columnsLeft = RowParser $ do+	RowInput (ResultInfo _ numCols) _ <- ask+	curCol <- get+	pure (numCols - curCol)++-- | Advance to next column without checking.+nextColumn :: RowParser ()+nextColumn =+	RowParser (modify (+ 1))++-- | Do something with the underlying result, row number and column number.+withColumn :: (P.Result -> P.Row -> P.Column -> RowParser a) -> RowParser a+withColumn action = do+	(RowInput (ResultInfo result numColumns) row, col) <- RowParser ((,) <$> ask <*> get)++	if col < numColumns then+		action result row col+	else+		throwError (RowError (RowErrorLocation col row) TooFewColumns)++-- | Fetch the 'TypedValue' associated with the current cell without advancing the cursor.+peekColumn :: RowParser TypedValue+peekColumn =+	withColumn $ \ result row col -> RowParser $ liftIO $+		TypedValue <$> P.ftype result col+		           <*> fmap (fmap Value) (P.getvalue' result row col)++-- | Fetch the type 'Oid' and value of the current cell. Also advances the cell cursor to the next+-- column.+fetchColumn :: RowParser TypedValue+fetchColumn =+	peekColumn <* nextColumn++-- | Fetch a column and parse it. Returning 'Nothing' from the provided parser function will cause+-- a 'ColumnRejected' to be raised. Advances the cell cursor to the next column.+parseColumn :: (TypedValue -> Maybe a) -> RowParser a+parseColumn proc = do+	typedValue <- peekColumn+	case proc typedValue of+		Just x  -> x <$ nextColumn+		Nothing -> do+			col <- columnNumber+			row <- rowNumber+			throwError (RowError (RowErrorLocation col row) (ColumnRejected typedValue))++-- | Fetch the cell's contents without moving the cell cursor.+peekContents :: RowParser (Maybe B.ByteString)+peekContents =+	withColumn (\ result row col -> RowParser (liftIO (P.getvalue' result row col)))++-- | Like 'peekContents' but moves the cell cursor to the next column.+fetchContents :: RowParser (Maybe B.ByteString)+fetchContents =+	peekContents <* nextColumn++-- | Parse the contents of a column (only if present). Returning 'Nothing' from the provided parser+-- function will raise a 'ContentsRejected'. When the cell is @NULL@, a 'ContentsRejected' is raised+-- aswell.+parseContents :: (B.ByteString -> Maybe a) -> RowParser a+parseContents proc = do+	value <- peekContents+	case value >>= proc of+		Just x  -> x <$ nextColumn+		Nothing -> do+			col <- columnNumber+			row <- rowNumber+			throwError (RowError (RowErrorLocation col row) (ContentsRejected value))++-- | Point cursor to the next column.+skipColumn :: RowParser ()+skipColumn = do+	(RowInput (ResultInfo _ numColumns) row, col) <- RowParser ((,) <$> ask <*> get)++	if col < numColumns then+		nextColumn+	else+		throwError (RowError (RowErrorLocation col row) TooFewColumns)++-- | Parse the result.+parseResult :: P.Result -> RowParser a -> ExceptT RowError IO [a]+parseResult result parser = do+	(resultInfo, numRows) <- liftIO $ do+		numColumns <- P.nfields result+		numRows <- P.ntuples result+		pure (ResultInfo result numColumns, numRows)++	forM [0 .. numRows - 1] (parseRow parser . RowInput resultInfo)

@@ -1,444 +1,228 @@-{-# LANGUAGE TemplateHaskell, BangPatterns #-}+{-# LANGUAGE OverloadedStrings,+             ConstraintKinds,+             DataKinds,+             FlexibleContexts,+             FlexibleInstances,+             TypeFamilies,+             TypeOperators,+             TypeSynonymInstances,+             UndecidableInstances,+             ScopedTypeVariables,+             QuasiQuotes,+             DefaultSignatures+#-}  -- | -- Module:     Database.PostgreSQL.Store.Table--- Copyright:  (c) Ole Krüger 2015-2016+-- Copyright:  (c) Ole Krüger 2016 -- License:    BSD3 -- Maintainer: Ole Krüger <ole@vprsm.de> module Database.PostgreSQL.Store.Table (-	-- * Auxiliary data types-	Reference (..),+	-- * Columns+	Column (..),+	ColumnType (..),+	ColumnEntity (..), -	-- * Table types+	-- * Table 	Table (..),-	mkCreateQuery,--	-- * Table generation-	TableConstraint (..),-	mkTable-) where--import Control.Monad-import Control.Monad.Except--import Data.Int-import Data.List hiding (insert)-import Data.Proxy-import Data.String--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---- | Reference a row of type @a@.-newtype Reference a = Reference { referenceID :: Int64 }-	deriving (Eq, Ord)--instance Show (Reference a) where-	show (Reference n) = show n--instance (QueryTable a) => Column (Reference a) where-	pack ref = pack (referenceID ref)--	unpack val = Reference <$> unpack val--	columnTypeName proxy =-		"BIGINT REFERENCES " ++ quoteIdentifier (tableName tableProxy) ++-		" (" ++ quoteIdentifier (tableIDName tableProxy) ++ ")"-		where-			tableProxy = (const Proxy :: Proxy (Reference a) -> Proxy a) proxy--	columnAllowNull _ = False--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 :: Reference a -> Errand a--	-- | Update an existing row.-	update :: Reference a -> a -> Errand ()--	-- | Delete a row from the table.-	delete :: Reference a -> Errand ()--	-- | Generate the query which creates this table inside the database.-	-- Use 'mkCreateQuery' for convenience.-	createTableQuery :: Proxy a -> Query---- | Table field declaration-data TableField = TableField String Type Name---- | Table type declaration-data TableDec = TableDec Name Name [TableField] Pat---- | Generate an identifier for a table type.-tableIdentifier :: Name -> String-tableIdentifier name = quoteIdentifier (show name)---- | Make a comma-seperated list of identifiers which correspond to given fields.-tableFieldIdentifiers :: [TableField] -> String-tableFieldIdentifiers fields =-	intercalate ", " (map (\ (TableField name _ _) -> quoteIdentifier name) fields)---- | Beginning of a insert statement.-tableInsertStatementBegin :: TableDec -> String-tableInsertStatementBegin (TableDec table _ fields _) =-	"INSERT INTO " ++-	tableIdentifier table ++-	" (" ++-	tableFieldIdentifiers fields ++-	") VALUES "---- | End of a insert statement.-tableInsertStatementEnd :: String-tableInsertStatementEnd =-	" RETURNING \"$id\""---- | Call a constructor with some variables.-callConstructor :: Name -> [Name] -> Exp-callConstructor ctor params =-	foldl AppE (ConE ctor) (map VarE params)---- | Generate the list of selectors.-makeQuerySelectors :: [TableField] -> Q Exp-makeQuerySelectors fields =-	ListE <$> mapM (\ (TableField field _ _) -> [e| SelectorField $(stringE field) |]) fields---- | 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-		-- Bind expression 'name <- unpackColumn'-		makeBinding name =-			BindS (VarP name) (VarE 'unpackColumn)--		-- Last expression 'pure (ctor boundNames...)'-		makeConstruction names =-			NoBindS (AppE (VarE 'pure) (callConstructor ctor names))+	TableEntity (..),+	buildTableSchema, --- | 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 " ("+	insertColumns,+	insertColumnsOn, -		intercalateBuilder (writeStringCode ", ") $-			identDescription :-			map describeField fields ++-			map describeConstraint constraints+	GenericTable,+	describeGenericTable, -		writeStringCode ")"-	where-		identDescription = do-			writeIdentifier "$id"-			writeStringCode "BIGSERIAL NOT NULL PRIMARY KEY"+	-- * Helpers+	KColumns (..),+	KTable (..), -		describeField :: TableField -> QueryBuilder [Q Exp] (Q Exp)-		describeField (TableField name typ _) =-			writeCode [e| fromString (columnDescription (Proxy :: Proxy $(pure typ))-			                                            $(stringE (quoteIdentifier name))) |]+	GColumns (..),+	GTable (..), -		describeConstraint :: TableConstraint -> QueryBuilder [Q Exp] (Q Exp)-		describeConstraint (Unique names) = do-			writeStringCode "UNIQUE ("-			intercalateBuilder (writeStringCode ", ") $-				map (writeIdentifier . nameBase) names-			writeStringCode ")"+	AnalyzeRecordRep,+	AnalyzeTableRep, -		describeConstraint (Check code) = do-			writeStringCode "CHECK ("-			writeStringCode code-			writeStringCode ")"+	AnalyzeTable+) where --- | 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"+import           GHC.Generics+import           GHC.TypeLits --- | 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) |]+import           Control.Monad --- | 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) |]+import           Data.Kind+import           Data.Proxy --- | 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) |]+import qualified Data.ByteString as B --- | 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) |]+import           Database.PostgreSQL.Store.Entity+import           Database.PostgreSQL.Store.Utilities+import           Database.PostgreSQL.Store.ColumnEntity+import           Database.PostgreSQL.Store.Query.Builder --- | 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)+-- | Type-level description of a record+data KColumns+	= TCombine KColumns KColumns+	| TSelector Symbol Type -		instance Result $(conT table) where-			queryResultProcessor = $(makeResultProcessor dec)+-- | Desciption of a column+data Column = Column {+	-- | Column name+	colName :: B.ByteString, -		instance Table $(conT table) where-			insert $(pure destructPat) = do-				rs <- query $(makeInsertQuery dec)-				case rs of-					(ref : _) -> pure ref-					_         -> throwError EmptyResult+	-- | Column type+	colType :: ColumnType+} -			insertMany [] = pure []-			insertMany rows =-				query $(makeInsertManyQuery 'rows dec)+-- | Provide the means to demote 'KColumns' to a value.+class GColumns (rec :: KColumns) where+	-- | Instantiate singleton+	gDescribeColumns :: proxy rec -> [Column] -			find ref = do-				rs <- query $(makeFindQuery 'ref dec)-				case rs of-					(row : _) -> pure row-					_         -> throwError EmptyResult+instance (KnownSymbol name, ColumnEntity typ) => GColumns ('TSelector name typ) where+	gDescribeColumns _ =+		[Column (buildByteString (symbolVal (Proxy :: Proxy name)))+		        (describeColumnType (Proxy :: Proxy typ))] -			update ref $(pure destructPat) =-				query_ $(makeUpdateQuery 'ref dec)+instance (GColumns lhs, GColumns rhs) => GColumns ('TCombine lhs rhs) where+	gDescribeColumns _ =+		gDescribeColumns (Proxy :: Proxy lhs)+		++ gDescribeColumns (Proxy :: Proxy rhs) -			delete ref =-				query_ $(makeDeleteQuery 'ref table)+-- | Check the 'Generic' representation of a record in order to generate an instance of 'KColumns'.+type family AnalyzeRecordRep org (rec :: * -> *) :: KColumns where+	-- Single record field+	AnalyzeRecordRep org (S1 ('MetaSel ('Just name) m1 m2 m3) (Rec0 typ)) =+		'TSelector name typ -			createTableQuery _ =-				$(makeCreateQuery dec constraints)-	|]+	-- Non-record field+	AnalyzeRecordRep org (S1 ('MetaSel 'Nothing m1 m2 m3) a) =+		TypeError ('Text "Given type "+		           ':<>: 'ShowType org+		           ':<>: 'Text " must have a single record constructor") --- | 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 ++ "'")+	-- Multiple fields+	AnalyzeRecordRep org (lhs :*: rhs) =+		'TCombine (AnalyzeRecordRep org lhs) (AnalyzeRecordRep org rhs) -		TableField (nameBase name) typ <$> newName (nameBase name)+	-- Missing field(s)+	AnalyzeRecordRep org U1 =+		TypeError ('Text "Given type "+		           ':<>: 'ShowType org+		           ':<>: 'Text " has one constructor, therefore that constructor must have \+		                       \at least one field") --- | 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 ++ "'")+	-- Something else+	AnalyzeRecordRep org other =+		TypeError ('Text "Given type "+		           ':<>: 'ShowType org+		           ':<>: 'Text " has a constructor with an invalid selector"+		           ':$$: 'ShowType other) -		TableField ("column" ++ show idx) typ <$> newName ("column" ++ show idx)+-- | Type-level description of a table+data KTable = TTable Symbol KColumns --- |-makeCtorPattern :: Name -> [TableField] -> Pat-makeCtorPattern ctor fields =-	ConP ctor (map (\ (TableField _ _ name) -> VarP name) fields)+-- | Description of a table+data Table = Table {+	-- | Table name+	tableName :: B.ByteString, --- | 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"))+	-- | Table columns+	tableCols :: [Column]+} -	fields <- checkRecordFields ctorFields-	pure (TableDec table ctor fields (makeCtorPattern ctor fields))+-- | Provide the means to demote 'KTable' to a value.+class GTable (tbl :: KTable) where+	-- | Instantiate singleton+	gDescribeTable :: proxy tbl -> Table -checkTableCtor table (NormalC ctor ctorFields) = do-	when (length ctorFields < 1)-	     (fail ("'" ++ show ctor ++ "' must have at least one field"))+instance (KnownSymbol name, GColumns cols) => GTable ('TTable name cols) where+	gDescribeTable _ =+		Table (buildByteString (symbolVal (Proxy :: Proxy name)))+		      (gDescribeColumns (Proxy :: Proxy cols)) -	fields <- checkNormalFields ctorFields-	pure (TableDec table ctor fields (makeCtorPattern ctor fields))+-- | Check the 'Generic' representation of a data type in order to generate an instance of 'KTable'.+type family AnalyzeTableRep org (dat :: * -> *) :: KTable where+	-- Single constructor+	AnalyzeTableRep org (D1 meta1 (C1 ('MetaCons name f 'True) sel)) =+		'TTable name (AnalyzeRecordRep org sel) -checkTableCtor table _ =-	fail ("'" ++ show table ++ "' must have a normal or record constructor")+	-- Data type with constructor(s) that does not match the given patterns+	AnalyzeTableRep org (D1 meta other) =+		TypeError ('Text "Given type "+		           ':<>: 'ShowType org+		           ':<>: 'Text " must have a single record constructor") --- | 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"))+	-- Something else+	AnalyzeTableRep org other =+		TypeError ('Text "Given type "+		           ':<>: 'ShowType org+		           ':<>: 'Text " is not a valid data type"+		           ':$$: 'ShowType other) -	when (length typeVars > 0)-	     (fail ("'" ++ show tableName ++ "' must not use type variables"))+-- | Analyzes a type in order to retrieve its 'KTable' representation.+type AnalyzeTable a = AnalyzeTableRep a (Rep a) -	when (length ctorNames /= 1)-	     (fail ("'" ++ show tableName ++ "' must have 1 constructor"))+-- | Constraint for generic tables+type GenericTable a = (Generic a, GTable (AnalyzeTable a)) -	when (kind /= Nothing && kind /= Just StarT)-	     (fail ("'" ++ show tableName ++ "' must have kind *"))+-- | Fetch the table description for a generic table type.+describeGenericTable :: (GenericTable a) => proxy a -> Table+describeGenericTable proxy =+	gDescribeTable ((const Proxy :: proxy a -> Proxy (AnalyzeTable a)) proxy) -	let [ctorName] = ctorNames+-- | Classify a type which can be used as a table.+class (Entity a) => TableEntity a where+	-- | Describe the table type.+	describeTableType :: proxy a -> Table -	checkTableCtor tableName ctorName+	default describeTableType :: (GenericTable a) => proxy a -> Table+	describeTableType = describeGenericTable -checkTableDec tableName _ =-	fail ("'" ++ show tableName ++ "' must declare a data type")+-- | Build SQL code which describes the column.+buildColumn :: Column -> QueryBuilder+buildColumn (Column name (ColumnType typeName notNull mbCheck)) = do+	insertName name+	insertCode " "+	insertName typeName --- | Options to 'mkTable'.-data TableConstraint-	= Unique [Name]-	  -- ^ A combination of fields must be unique.-	  --   @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)+	when notNull (insertCode " NOT NULL") --- | 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---   * One record constructor with 1 or more fields---   * All field types must have an instance of 'Column'------ Example:------ @--- {-\# LANGUAGE TemplateHaskell, QuasiQuotes \#-}--- module Movies where------ ...------ data Movie = Movie {---     movieTitle :: 'String',---     movieYear  :: 'Int'--- } deriving 'Show'------ 'mkTable' ''Movie []------ data Actor = Actor {---     actorName :: 'String',---     actorAge  :: 'Int'--- } deriving 'Show'------ 'mkTable' ''Actor ['Unique' ['actorName], 'Check' ['pgss'| actorAge >= 18 |]]------ data MovieCast = MovieCast {---     movieCastMovie :: 'Reference' Movie,---     movieCastActor :: 'Reference' Actor--- } deriving 'Show'------ '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 -> do-			tableDec <- checkTableDec name dec-			implementClasses tableDec constraints+	case mbCheck of+		Just gen -> do+			insertCode " CHECK("+			gen name+			insertCode ")" -		_ -> fail ("'" ++ show name ++ "' is not a type constructor")+		Nothing -> pure () --- | Check if the given name refers to a type.-isType :: Name -> Q Bool-isType name = do-	info <- reify name-	pure $ case info of-		TyConI _ -> True-		_        -> False+-- | Build the SQL code which describes and creates the table.+buildTableSchema :: Table -> QueryBuilder+buildTableSchema (Table name cols) = do+	insertCode "CREATE TABLE IF NOT EXISTS "+	insertName name+	insertCode "("+	insertCommaSeperated (map buildColumn cols)+	insertCode ")" --- | Generate a 'Query' expression which will create the table described by the given type.------ Example:------ @--- data Table = Table { myField :: Int }--- 'mkTable' ''Table []--- ...--- 'query_' $('mkCreateQuery' ''Table)--- @----mkCreateQuery :: Name -> Q Exp-mkCreateQuery name = do-	-- Is the given name a type?-	it <- isType name-	unless it (fail "Given name does not refer to a type.")+-- | Insert a comma-seperated list of the fully qualified column names of a table.+insertColumns :: Table -> QueryBuilder+insertColumns (Table name cols) =+	insertCommaSeperated (map insertColumn cols)+	where+		insertColumn (Column colName _) = do+			insertName name+			insertCode "."+			insertName colName -	-- Actual splice-	[e| createTableQuery (Proxy :: Proxy $(pure (ConT name))) |]+-- | Similar to 'insertColumns', but instead it expands the column names on an alias.+insertColumnsOn :: Table -> B.ByteString -> QueryBuilder+insertColumnsOn (Table _ cols) name =+	insertCommaSeperated (map insertColumn cols)+	where+		insertColumn (Column colName _) = do+			insertName name+			insertCode "."+			insertName colName

@@ -0,0 +1,28 @@+-- |+-- Module:     Database.PostgreSQL.Store.Types+-- Copyright:  (c) Ole Krüger 2016+-- License:    BSD3+-- Maintainer: Ole Krüger <ole@vprsm.de>+module Database.PostgreSQL.Store.Types (+	-- * General+	Value (..),+	TypedValue (..),+	Query (..)+) where++import qualified Data.ByteString           as B+import qualified Database.PostgreSQL.LibPQ as P++-- | Value of a cell in the result set+newtype Value = Value { valueData :: B.ByteString }+	deriving (Show, Eq, Ord)++-- | Value and type 'P.Oid' of a cell in the result set+data TypedValue = TypedValue P.Oid (Maybe Value)+	deriving (Show, Eq, Ord)++-- | Query+data Query a = Query {+	queryStatement :: B.ByteString,+	queryParams    :: [TypedValue]+} deriving (Show, Eq, Ord)

@@ -0,0 +1,44 @@+{-# LANGUAGE TemplateHaskell #-}++-- |+-- Module:     Database.PostgreSQL.Store.Utilities+-- Copyright:  (c) Ole Krüger 2016+-- License:    BSD3+-- Maintainer: Ole Krüger <ole@vprsm.de>+module Database.PostgreSQL.Store.Utilities (+	showByteString,+	readByteString,+	buildByteString,+	liftByteString+) where++import           Language.Haskell.TH+import           Language.Haskell.TH.Syntax++import qualified Data.ByteString                    as B+import qualified Blaze.ByteString.Builder           as B+import qualified Blaze.ByteString.Builder.Char.Utf8 as B+import qualified Data.Text                          as T+import qualified Data.Text.Encoding                 as T++import           Text.Read (readMaybe)++-- | Show as 'ByteString'+showByteString :: (Show a) => a -> B.ByteString+showByteString =+	B.toByteString . B.fromString . show++-- | Read as 'ByteString'+readByteString :: (Read a) => B.ByteString -> Maybe a+readByteString =+	readMaybe . T.unpack . T.decodeUtf8++-- | UTF-8 correct alternative to 'fromString'.+buildByteString :: String -> B.ByteString+buildByteString =+	B.toByteString . B.fromString++-- | Lift 'ByteString'.+liftByteString :: B.ByteString -> Q Exp+liftByteString bs =+	[e| B.pack $(lift (B.unpack bs)) |]

@@ -1,29 +0,0 @@-module Main (main) where--import           Test.Hspec-import           Test.Database.PostgreSQL.Store--import           Data.String--import qualified Database.PostgreSQL.LibPQ as P--import           System.Environment--connectMaybe :: String -> IO (Maybe P.Connection)-connectMaybe info = do-	con <- P.connectdb (fromString info)-	status <- P.status con--	pure $-		if status == P.ConnectionOk then-			Just con-		else-			Nothing---- | Test entry point-main :: IO ()-main = do-	mbInfo <- lookupEnv "PGINFO"-	mbCon <- maybe (pure Nothing) connectMaybe mbInfo--	hspec (allSpecs mbCon)

@@ -1,17 +0,0 @@-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

@@ -1,117 +0,0 @@-{-# 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)

@@ -1,92 +0,0 @@-{-# 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\"" [])

@@ -1,140 +0,0 @@-{-# 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"