packages feed

postgresql-typed 0.3.1 → 0.3.2

raw patch · 11 files changed

+196/−98 lines, 11 filesdep ~containersdep ~time

Dependency ranges changed: containers, time

Files

Database/PostgreSQL/Typed/Array.hs view
@@ -10,9 +10,10 @@  module Database.PostgreSQL.Typed.Array where -import Control.Applicative ((<$>), (<$))+import Control.Applicative ((<$>)) import qualified Data.ByteString.Builder as BSB import qualified Data.ByteString.Char8 as BSC+import Data.Char (toLower) import Data.List (intersperse) import Data.Monoid ((<>), mconcat) import qualified Text.Parsec as P@@ -38,15 +39,14 @@     el Nothing = BSB.string7 "null"     el (Just e) = pgDQuote (pgArrayDelim ta : "{}") $ pgEncode (pgArrayElementType ta) e instance (PGArrayType ta t, PGColumn t a) => PGColumn ta (PGArray a) where-  pgDecode ta = either (error . ("pgDecode array: " ++) . show) id . P.parse pa "array" where+  pgDecode ta a = either (error . ("pgDecode array: " ++) . show) id $ P.parse pa (BSC.unpack a) a where     pa = do       l <- P.between (P.char '{') (P.char '}') $-        P.sepBy nel (P.char (pgArrayDelim ta))+        P.sepBy el (P.char (pgArrayDelim ta))       _ <- P.eof       return l-    nel = P.between P.spaces P.spaces $ Nothing <$ nul P.<|> Just <$> el-    nul = P.oneOf "Nn" >> P.oneOf "Uu" >> P.oneOf "Ll" >> P.oneOf "Ll"-    el = pgDecode (pgArrayElementType ta) . BSC.pack <$> parsePGDQuote (pgArrayDelim ta : "{}")+    el = P.between P.spaces P.spaces $ fmap (pgDecode (pgArrayElementType ta) . BSC.pack) <$>+      parsePGDQuote (pgArrayDelim ta : "{}") (("null" ==) . map toLower)  -- Just a dump of pg_type: instance PGType "boolean" => PGType "boolean[]"
Database/PostgreSQL/Typed/Dynamic.hs view
@@ -62,17 +62,17 @@   pgDecodeRep PGNullValue = Nothing   pgDecodeRep v = Just (pgDecodeRep v) -instance PGRep "boolean" Bool where-instance PGRep "oid" OID where-instance PGRep "smallint" Int16 where-instance PGRep "integer" Int32 where-instance PGRep "bigint" Int64 where-instance PGRep "real" Float where-instance PGRep "double precision" Double where-instance PGRep "\"char\"" Char where-instance PGRep "text" String where+instance PGRep "boolean" Bool+instance PGRep "oid" OID+instance PGRep "smallint" Int16+instance PGRep "integer" Int32+instance PGRep "bigint" Int64+instance PGRep "real" Float+instance PGRep "double precision" Double+instance PGRep "\"char\"" Char+instance PGRep "text" String #ifdef USE_TEXT-instance PGRep "text" T.Text where+instance PGRep "text" T.Text #endif instance PGRep "date" Time.Day instance PGRep "time without time zone" Time.TimeOfDay@@ -81,10 +81,10 @@ instance PGRep "interval" Time.DiffTime instance PGRep "numeric" Rational #ifdef USE_SCIENTIFIC-instance PGRep "numeric" Scientific where+instance PGRep "numeric" Scientific #endif #ifdef USE_UUID-instance PGRep "uuid" UUID.UUID where+instance PGRep "uuid" UUID.UUID #endif  -- |Create an expression that literally substitutes each instance of @${expr}@ for the result of @pgSafeLiteral expr@.
Database/PostgreSQL/Typed/Enum.hs view
@@ -6,12 +6,16 @@ -- Support for PostgreSQL enums.  module Database.PostgreSQL.Typed.Enum -  ( makePGEnum+  ( PGEnum+  , pgEnumValues+  , makePGEnum   ) where  import Control.Monad (when)+import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BSC import qualified Data.ByteString.UTF8 as U+import Data.Typeable (Typeable) import qualified Language.Haskell.TH as TH  import Database.PostgreSQL.Typed.Protocol@@ -19,17 +23,26 @@ import Database.PostgreSQL.Typed.Types import Database.PostgreSQL.Typed.Dynamic +-- |A type based on a PostgreSQL enum. Automatically instantiated by 'makePGEnum'.+class (Eq a, Ord a, Enum a, Bounded a, Show a) => PGEnum a++-- |List of all the values in the enum along with their database names.+pgEnumValues :: PGEnum a => [(a, String)]+pgEnumValues = map (\e -> (e, show e)) $ enumFromTo minBound maxBound+ -- |Create a new enum type corresponding to the given PostgreSQL enum type. -- For example, if you have @CREATE TYPE foo AS ENUM (\'abc\', \'DEF\');@, then -- @makePGEnum \"foo\" \"Foo\" (\"Foo_\"++)@ will be equivalent to: -- --- @--- data Foo = Foo_abc | Foo_DEF deriving (Eq, Ord, Enum, Bounded, Show, Read)--- instance PGType Foo where ...--- registerPGType \"foo\" (ConT ''Foo)--- @+-- > data Foo = Foo_abc | Foo_DEF deriving (Eq, Ord, Enum, Bounded, Typeable)+-- > instance Show Foo where show Foo_abc = "abc" ...+-- > instance PGType "foo"+-- > instance PGParameter "foo" Foo where ...+-- > instance PGColumn "foo" Foo where ...+-- > instance PGRep "foo" Foo+-- > instance PGEnum Foo where pgEnumValues = [(Foo_abc, "abc"), (Foo_DEF, "DEF")] ----- Requires language extensions: TemplateHaskell, FlexibleInstances, MultiParamTypeClasses, DataKinds+-- Requires language extensions: TemplateHaskell, FlexibleInstances, MultiParamTypeClasses, DeriveDataTypeable, DataKinds makePGEnum :: String -- ^ PostgreSQL enum type name   -> String -- ^ Haskell type to create   -> (String -> String) -- ^ How to generate constructor names from enum values, e.g. @(\"Type_\"++)@@@ -39,24 +52,30 @@     pgSimpleQuery c $ "SELECT enumlabel FROM pg_catalog.pg_enum JOIN pg_catalog.pg_type t ON enumtypid = t.oid WHERE typtype = 'e' AND format_type(t.oid, -1) = " ++ pgQuote name ++ " ORDER BY enumsortorder"   when (null vals) $ fail $ "makePGEnum: enum " ++ name ++ " not found"   let -    valn = map (\[PGTextValue v] -> (TH.StringL (BSC.unpack v), TH.mkName $ valnf (U.toString v))) vals+    valn = map (\[PGTextValue v] -> let u = U.toString v in (TH.mkName $ valnf u, map (TH.IntegerL . fromIntegral) $ BS.unpack v, TH.StringL u)) vals   dv <- TH.newName "x"-  ds <- TH.newName "s"   return-    [ TH.DataD [] typn [] (map (\(_, n) -> TH.NormalC n []) valn) [''Eq, ''Ord, ''Enum, ''Bounded, ''Show, ''Read]+    [ TH.DataD [] typn [] (map (\(n, _, _) -> TH.NormalC n []) valn) [''Eq, ''Ord, ''Enum, ''Bounded, ''Typeable]+    , TH.InstanceD [] (TH.ConT ''Show `TH.AppT` typt)+      [ TH.FunD 'show $ map (\(n, _, v) -> TH.Clause [TH.ConP n []]+        (TH.NormalB $ TH.LitE v) []) valn+      ]     , TH.InstanceD [] (TH.ConT ''PGType `TH.AppT` typl) []     , TH.InstanceD [] (TH.ConT ''PGParameter `TH.AppT` typl `TH.AppT` typt)-      [ TH.FunD 'pgEncode $ map (\(l, n) -> TH.Clause [TH.WildP, TH.ConP n []]-        (TH.NormalB $ TH.VarE 'BSC.pack `TH.AppE` TH.LitE l) []) valn ]+      [ TH.FunD 'pgEncode $ map (\(n, l, _) -> TH.Clause [TH.WildP, TH.ConP n []]+        (TH.NormalB $ TH.VarE 'BS.pack `TH.AppE` TH.ListE (map TH.LitE l)) []) valn+      ]     , TH.InstanceD [] (TH.ConT ''PGColumn `TH.AppT` typl `TH.AppT` typt)       [ TH.FunD 'pgDecode [TH.Clause [TH.WildP, TH.VarP dv]-        (TH.NormalB $ TH.CaseE (TH.VarE 'BSC.unpack `TH.AppE` TH.VarE dv) $ map (\(l, n) ->-          TH.Match (TH.LitP l) (TH.NormalB $ TH.ConE n) []) valn ++-          [TH.Match (TH.VarP ds) (TH.NormalB $ TH.AppE (TH.VarE 'error) $-            TH.InfixE (Just $ TH.LitE (TH.StringL ("pgDecode " ++ name ++ ": "))) (TH.VarE '(++)) (Just $ TH.VarE ds))+        (TH.NormalB $ TH.CaseE (TH.VarE 'BS.unpack `TH.AppE` TH.VarE dv) $ map (\(n, l, _) ->+          TH.Match (TH.ListP (map TH.LitP l)) (TH.NormalB $ TH.ConE n) []) valn +++          [TH.Match TH.WildP (TH.NormalB $ TH.AppE (TH.VarE 'error) $+            TH.InfixE (Just $ TH.LitE (TH.StringL ("pgDecode " ++ name ++ ": "))) (TH.VarE '(++)) (Just $ TH.VarE 'BSC.unpack `TH.AppE` TH.VarE dv))             []])-        []] ]+        []] +      ]     , TH.InstanceD [] (TH.ConT ''PGRep `TH.AppT` typl `TH.AppT` typt) []+    , TH.InstanceD [] (TH.ConT ''PGEnum `TH.AppT` typt) []     ]   where   typn = TH.mkName typs
+ Database/PostgreSQL/Typed/Inet.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FunctionalDependencies, DataKinds #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- |+-- Module: Database.PostgreSQL.Typed.Inet+-- Copyright: 2015 Dylan Simon+-- +-- Representaion of PostgreSQL's inet/cidr types using "Network.Socket".+-- We don't (yet) supply PGColumn (parsing) instances.++module Database.PostgreSQL.Typed.Inet where++import qualified Data.ByteString.Char8 as BSC+import Data.Maybe (fromJust)+import qualified Network.Socket as Net+import System.IO.Unsafe (unsafeDupablePerformIO)++import Database.PostgreSQL.Typed.Types++data PGInet +  = PGInet+    { pgInetAddr :: !Net.HostAddress+    , pgInetMask :: !Int+    }+  | PGInet6+    { pgInetAddr6 :: !Net.HostAddress6+    , pgInetMask :: !Int+    }++sockAddrPGInet :: Net.SockAddr -> Maybe PGInet+sockAddrPGInet (Net.SockAddrInet _ a) = Just $ PGInet a 32+sockAddrPGInet (Net.SockAddrInet6 _ _ a _) = Just $ PGInet6 a 128+sockAddrPGInet _ = Nothing++instance Show PGInet where+  -- This is how Network.Socket's Show SockAddr does it:+  show (PGInet a 32) = unsafeDupablePerformIO $ Net.inet_ntoa a+  show (PGInet a m) = show (PGInet a 32) ++ '/' : show m+  show (PGInet6 a 128) = fromJust $ fst $ unsafeDupablePerformIO $+    Net.getNameInfo [Net.NI_NUMERICHOST] True False (Net.SockAddrInet6 0 0 a 0)+  show (PGInet6 a m) = show (PGInet6 a 128) ++ '/' : show m++instance PGType "inet"+instance PGType "cidr"+instance PGParameter "inet" PGInet where+  pgEncode _ = BSC.pack . show+instance PGParameter "cidr" PGInet where+  pgEncode _ = BSC.pack . show
Database/PostgreSQL/Typed/Protocol.hs view
@@ -540,14 +540,14 @@   pgFlush h   go start where    go = (pgReceive h >>=)-  start (RowDescription rd) = go (row (map colBinary rd))-  start (CommandComplete c) = got c+  start (RowDescription rd) = go $ row (map colBinary rd) id+  start (CommandComplete c) = got c []   start EmptyQueryResponse = return (0, [])   start m = fail $ "pgSimpleQuery: unexpected response: " ++ show m-  row bc (DataRow fs) = second (fixBinary bc fs :) <$> go (row bc)-  row _ (CommandComplete c) = got c-  row _ m = fail $ "pgSimpleQuery: unexpected row: " ++ show m-  got c = return (rowsAffected c, [])+  row bc r (DataRow fs) = go $ row bc (r . (fixBinary bc fs :))+  row _ r (CommandComplete c) = got c (r [])+  row _ _ m = fail $ "pgSimpleQuery: unexpected row: " ++ show m+  got c r = return (rowsAffected c, r)  pgPreparedBind :: PGConnection -> String -> [OID] -> PGValues -> [Bool] -> IO (IO ()) pgPreparedBind c@PGConnection{ connPreparedStatements = psr } sql types bind bc = do@@ -583,13 +583,13 @@   pgSend c Sync   pgFlush c   start-  go+  go id   where-  go = pgReceive c >>= row-  row (DataRow fs) = second (fixBinary bc fs :) <$> go-  row (CommandComplete r) = return (rowsAffected r, [])-  row EmptyQueryResponse = return (0, [])-  row m = fail $ "pgPreparedQuery: unexpected row: " ++ show m+  go r = pgReceive c >>= row r+  row r (DataRow fs) = go (r . (fixBinary bc fs :))+  row r (CommandComplete d) = return (rowsAffected d, r [])+  row r EmptyQueryResponse = return (0, r [])+  row _ m = fail $ "pgPreparedQuery: unexpected row: " ++ show m  -- |Like 'pgPreparedQuery' but requests results lazily in chunks of the given size. -- Does not use a named portal, so other requests may not intervene.@@ -600,18 +600,18 @@   unsafeInterleaveIO $ do     execute     start-    go+    go id   where   execute = do     pgSend c $ Execute count     pgSend c $ Flush     pgFlush c-  go = pgReceive c >>= row-  row (DataRow fs) = (fixBinary bc fs :) <$> go-  row PortalSuspended = unsafeInterleaveIO (execute >> go)-  row (CommandComplete _) = return []-  row EmptyQueryResponse = return []-  row m = fail $ "pgPreparedLazyQuery: unexpected row: " ++ show m+  go r = pgReceive c >>= row r+  row r (DataRow fs) = go (r . (fixBinary bc fs :))+  row r PortalSuspended = r <$> unsafeInterleaveIO (execute >> go id)+  row r (CommandComplete _) = return (r [])+  row r EmptyQueryResponse = return (r [])+  row _ m = fail $ "pgPreparedLazyQuery: unexpected row: " ++ show m  -- |Close a previously prepared query (if necessary). pgCloseStatement :: PGConnection -> String -> [OID] -> IO ()
Database/PostgreSQL/Typed/Query.hs view
@@ -7,6 +7,7 @@   , rawPGPreparedQuery   , QueryFlags(..)   , simpleQueryFlags+  , parseQueryFlags   , makePGQuery   , pgSQL   , pgExecute@@ -20,8 +21,10 @@ import Control.Monad (when, mapAndUnzipM) import Data.Array (listArray, (!), inRange) import Data.Char (isDigit, isSpace)+import qualified Data.Foldable as Fold import Data.List (dropWhileEnd) import Data.Maybe (fromMaybe, isNothing)+import Data.String (IsString(..)) import Data.Word (Word32) import Language.Haskell.Meta.Parse (parseExp) import qualified Language.Haskell.TH as TH@@ -37,6 +40,10 @@ class PGQuery q a | q -> a where   -- |Execute a query and return the number of rows affected (or -1 if not known) and a list of results.   pgRunQuery :: PGConnection -> q -> IO (Int, [a])+  -- |Change the raw SQL query stored within this query.+  -- This is unsafe because the query has already been type-checked, so any change must not change the number or type of results or placeholders (so adding additional static WHERE or ORDER BY clauses is generally safe).+  -- This is useful in cases where you need to construct some part of the query dynamically, but still want to infer the result types.+  unsafeModifyQuery :: q -> (String -> String) -> q class PGQuery q PGValues => PGRawQuery q  -- |Execute a query that does not return results.@@ -48,22 +55,27 @@ pgQuery :: PGQuery q a => PGConnection -> q -> IO [a] pgQuery c q = snd <$> pgRunQuery c q +instance PGQuery String PGValues where+  pgRunQuery c sql = pgSimpleQuery c sql+  unsafeModifyQuery q f = f q -data SimpleQuery = SimpleQuery String+newtype SimpleQuery = SimpleQuery String instance PGQuery SimpleQuery PGValues where   pgRunQuery c (SimpleQuery sql) = pgSimpleQuery c sql-instance PGRawQuery SimpleQuery where-+  unsafeModifyQuery (SimpleQuery sql) f = SimpleQuery $ f sql+instance PGRawQuery SimpleQuery  data PreparedQuery = PreparedQuery String [OID] PGValues [Bool] instance PGQuery PreparedQuery PGValues where   pgRunQuery c (PreparedQuery sql types bind bc) = pgPreparedQuery c sql types bind bc-instance PGRawQuery PreparedQuery where+  unsafeModifyQuery (PreparedQuery sql types bind bc) f = PreparedQuery (f sql) types bind bc+instance PGRawQuery PreparedQuery   data QueryParser q a = QueryParser (PGTypeEnv -> q) (PGTypeEnv -> PGValues -> a) instance PGRawQuery q => PGQuery (QueryParser q a) a where   pgRunQuery c (QueryParser q p) = second (fmap $ p e) <$> pgRunQuery c (q e) where e = pgTypeEnv c+  unsafeModifyQuery (QueryParser q p) f = QueryParser (\e -> unsafeModifyQuery (q e) f) p  instance Functor (QueryParser q) where   fmap f (QueryParser q p) = QueryParser q (\e -> f . p e)@@ -80,6 +92,9 @@ rawPGSimpleQuery :: String -> PGSimpleQuery PGValues rawPGSimpleQuery = rawParser . SimpleQuery +instance IsString (PGSimpleQuery PGValues) where+  fromString = rawPGSimpleQuery+ -- |Make a prepared query directly from a query string and bind parameters, with no type inference rawPGPreparedQuery :: String -> PGValues -> PGPreparedQuery PGValues rawPGPreparedQuery sql bind = rawParser $ PreparedQuery sql [] bind []@@ -133,20 +148,20 @@  -- |Flags affecting how and what type of query to build with 'makePGQuery'. data QueryFlags = QueryFlags-  { flagQuery :: Bool -- ^ Create a query -- otherwise just call 'pgSubstituteLiterals' to create a string (SQL fragment)-  , flagNullable :: Bool -- ^ Assume all results are nullable and don't try to guess.+  { flagQuery :: Bool -- ^ Create a query -- otherwise just call 'pgSubstituteLiterals' to create a string (SQL fragment).+  , flagNullable :: Maybe Bool -- ^ Disable nullability inference, treating all values as nullable (if 'True') or not (if 'False').   , flagPrepare :: Maybe [String] -- ^ Prepare and re-use query, binding parameters of the given types (inferring the rest, like PREPARE).   }  -- |'QueryFlags' for a default (simple) query. simpleQueryFlags :: QueryFlags-simpleQueryFlags = QueryFlags True False Nothing+simpleQueryFlags = QueryFlags True Nothing Nothing  -- |Construct a 'PGQuery' from a SQL string. makePGQuery :: QueryFlags -> String -> TH.ExpQ makePGQuery QueryFlags{ flagQuery = False } sqle = pgSubstituteLiterals sqle makePGQuery QueryFlags{ flagNullable = nulls, flagPrepare = prep } sqle = do-  (pt, rt) <- TH.runIO $ tpgDescribe sqlp (fromMaybe [] prep) (not nulls)+  (pt, rt) <- TH.runIO $ tpgDescribe sqlp (fromMaybe [] prep) (isNothing nulls)   when (length pt < length exprs) $ fail "Not all expression placeholders were recognized by PostgreSQL; literal occurrences of '${' may need to be escaped with '$${'"    e <- TH.newName "_tenv"@@ -160,7 +175,7 @@     v <- TH.newName $ 'c':tpgValueName t     return        ( TH.VarP v-      , tpgTypeDecoder t e `TH.AppE` TH.VarE v+      , tpgTypeDecoder (Fold.and nulls) t e `TH.AppE` TH.VarE v       , tpgTypeBinary t e       )) rt   foldl TH.AppE (TH.LamE vars $ TH.ConE 'QueryParser@@ -184,17 +199,23 @@   (sqlp, exprs) = sqlPlaceholders sqle   parse e = either (fail . (++) ("Failed to parse expression {" ++ e ++ "}: ")) return $ parseExp e -qqQuery :: QueryFlags -> String -> TH.ExpQ-qqQuery f@QueryFlags{ flagQuery = True, flagPrepare = Nothing } ('#':q) = qqQuery f{ flagQuery = False } q-qqQuery f@QueryFlags{ flagQuery = True, flagNullable = False } ('?':q) = qqQuery f{ flagNullable = True } q-qqQuery f@QueryFlags{ flagQuery = True, flagPrepare = Nothing } ('$':q) = qqQuery f{ flagPrepare = Just [] } q-qqQuery f@QueryFlags{ flagQuery = True, flagPrepare = Just [] } ('(':s) = qqQuery f{ flagPrepare = Just args } =<< sql r where-  args = map trim $ splitCommas arg-  (arg, r) = break (')' ==) s-  sql (')':q) = return q-  sql _ = fail "pgSQL: unterminated argument list" -qqQuery f q = makePGQuery f q+-- |Parse flags off the beginning of a query string, returning the flags and the remaining string.+parseQueryFlags :: String -> (QueryFlags, String)+parseQueryFlags = pqf simpleQueryFlags where+  pqf f@QueryFlags{ flagQuery = True, flagPrepare = Nothing } ('#':q) = pqf f{ flagQuery = False } q+  pqf f@QueryFlags{ flagQuery = True, flagNullable = Nothing } ('?':q) = pqf f{ flagNullable = Just True } q+  pqf f@QueryFlags{ flagQuery = True, flagNullable = Nothing } ('!':q) = pqf f{ flagNullable = Just False } q+  pqf f@QueryFlags{ flagQuery = True, flagPrepare = Nothing } ('$':q) = pqf f{ flagPrepare = Just [] } q+  pqf f@QueryFlags{ flagQuery = True, flagPrepare = Just [] } ('(':s) = pqf f{ flagPrepare = Just args } (sql r) where+    args = map trim $ splitCommas arg+    (arg, r) = break (')' ==) s+    sql (')':q) = q+    sql _ = error "pgSQL: unterminated argument list" +  pqf f q = (f, q) +qqQuery :: String -> TH.ExpQ+qqQuery = uncurry makePGQuery . parseQueryFlags+ qqTop :: Bool -> String -> TH.DecsQ qqTop True ('!':sql) = qqTop False sql qqTop err sql = do@@ -215,7 +236,8 @@ -- -- The statement may start with one of more special flags affecting the interpretation: ----- [@?@] To disable nullability inference, treating all result values as nullable, thus returning 'Maybe' values regardless of inferred nullability.+-- [@?@] To disable nullability inference, treating all result values as nullable, thus returning 'Maybe' values regardless of inferred nullability. This makes unexpected NULL errors impossible.+-- [@!@] To disable nullability inference, treating all result values as /not/ nullable, thus only returning 'Maybe' where requested. This is makes unexpected NULL errors more likely. -- [@$@] To create a 'PGPreparedQuery' rather than a 'PGSimpleQuery', by default inferring parameter types. -- [@$(type,...)@] To specify specific types to a prepared query (see <http://www.postgresql.org/docs/current/static/sql-prepare.html> for details). -- [@#@] Only do literal @${}@ substitution using 'pgSubstituteLiterals' and return a string, not a query.@@ -224,7 +246,7 @@ -- Here the query can only be prefixed with @!@ to make errors non-fatal. pgSQL :: QuasiQuoter pgSQL = QuasiQuoter-  { quoteExp = qqQuery simpleQueryFlags+  { quoteExp = qqQuery   , quoteType = const $ fail "pgSQL not supported in types"   , quotePat = const $ fail "pgSQL not supported in patterns"   , quoteDec = qqTop True
Database/PostgreSQL/Typed/Range.hs view
@@ -167,12 +167,11 @@     pb (Just b) = pgDQuote "(),[]" $ pgEncode (pgRangeElementType tr) b     pc c o b = BSB.char7 $ if boundClosed b then c else o instance (PGRangeType tr t, PGColumn t a) => PGColumn tr (Range a) where-  pgDecode tr = either (error . ("pgDecode range: " ++) . show) id . P.parse per "range" where+  pgDecode tr a = either (error . ("pgDecode range: " ++) . show) id $ P.parse per (BSC.unpack a) a where     per = Empty <$ pe P.<|> pr     pe = P.oneOf "Ee" >> P.oneOf "Mm" >> P.oneOf "Pp" >> P.oneOf "Tt" >> P.oneOf "Yy"-    pp = pgDecode (pgRangeElementType tr) . BSC.pack <$> parsePGDQuote "(),[]"+    pb = fmap (pgDecode (pgRangeElementType tr) . BSC.pack) <$> parsePGDQuote "(),[]" null     pc c o = True <$ P.char c P.<|> False <$ P.char o-    pb = P.optionMaybe $ P.between P.spaces P.spaces $ pp     mb = maybe Unbounded . Bounded     pr = do       lc <- pc '[' '('
Database/PostgreSQL/Typed/TH.hs view
@@ -169,9 +169,9 @@     else 'pgEncodeParameter  -- |TH expression to decode a 'Maybe' 'L.ByteString' to a ('Maybe') 'PGColumn' value.-tpgTypeDecoder :: TPGValueInfo -> TH.Name -> TH.Exp-tpgTypeDecoder v = typeApply (tpgValueType v) $-  if tpgValueNullable v+tpgTypeDecoder :: Bool -> TPGValueInfo -> TH.Name -> TH.Exp+tpgTypeDecoder nulls v = typeApply (tpgValueType v) $+  if nulls && tpgValueNullable v     then 'pgDecodeColumn     else 'pgDecodeColumnNotNull
Database/PostgreSQL/Typed/Types.hs view
@@ -14,6 +14,7 @@   , PGTypeName(..)   , PGTypeEnv(..)   , unknownPGTypeEnv+  , PGRecord(..)    -- * Marshalling classes   , PGType(..)@@ -192,11 +193,14 @@   bs = BSBP.liftFixedToBounded $ ((,) '\\') BSBP.>$< (BSBP.char7 BSBP.>*< BSBP.word8)  -- |Parse double-quoted values ala 'pgDQuote'.-parsePGDQuote :: P.Stream s m Char => String -> P.ParsecT s u m String-parsePGDQuote unsafe = (q P.<|> uq) where+parsePGDQuote :: P.Stream s m Char => String -> (String -> Bool) -> P.ParsecT s u m (Maybe String)+parsePGDQuote unsafe isnul = (Just <$> q P.<|> mnul <$> uq) where   q = P.between (P.char '"') (P.char '"') $     P.many $ (P.char '\\' >> P.anyChar) P.<|> P.noneOf "\\\""-  uq = P.many1 (P.noneOf ('"':'\\':unsafe))+  uq = P.many (P.noneOf ('"':'\\':unsafe))+  mnul s+    | isnul s = Nothing+    | otherwise = Just s  #ifdef USE_BINARY binDec :: PGType t => BinD.D a -> PGTypeName t -> PGBinaryValue -> a@@ -455,7 +459,7 @@ -- PostgreSQL stores months and days separately in intervals, but DiffTime does not. -- We collapse all interval fields into seconds instance PGColumn "interval" Time.DiffTime where-  pgDecode _ = either (error . ("pgDecode interval: " ++) . show) id . P.parse ps "interval" where+  pgDecode _ a = either (error . ("pgDecode interval: " ++) . show) id $ P.parse ps (BSC.unpack a) a where     ps = do       _ <- P.char 'P'       d <- units [('Y', 12*month), ('M', month), ('W', 7*day), ('D', day)]@@ -540,21 +544,21 @@ #endif  -- |Generic class of composite (row or record) types.+newtype PGRecord = PGRecord [Maybe PGTextValue] class PGType t => PGRecordType t-instance PGRecordType t => PGParameter t [Maybe PGTextValue] where-  pgEncode _ l =+instance PGRecordType t => PGParameter t PGRecord where+  pgEncode _ (PGRecord l) =     buildPGValue $ BSB.char7 '(' <> mconcat (intersperse (BSB.char7 ',') $ map (maybe mempty (pgDQuote "(),")) l) <> BSB.char7 ')' where-  pgLiteral _ l =+  pgLiteral _ (PGRecord l) =     "ROW(" ++ intercalate "," (map (maybe "NULL" (pgQuote . BSU.toString)) l) ++ ")" where-instance PGRecordType t => PGColumn t [Maybe PGTextValue] where-  pgDecode _ = either (error . ("pgDecode record: " ++) . show) id . P.parse pa "record" where+instance PGRecordType t => PGColumn t PGRecord where+  pgDecode _ a = either (error . ("pgDecode record: " ++) . show) PGRecord $ P.parse pa (BSC.unpack a) a where     pa = do       l <- P.between (P.char '(') (P.char ')') $-        P.sepBy nel (P.char ',')+        P.sepBy el (P.char ',')       _ <- P.eof       return l-    nel = P.optionMaybe $ P.between P.spaces P.spaces el-    el = BSC.pack <$> parsePGDQuote "(),"+    el = fmap BSC.pack <$> parsePGDQuote "()," null  instance PGType "record" -- |The generic anonymous record type, as created by @ROW@.
postgresql-typed.cabal view
@@ -1,11 +1,11 @@ Name:          postgresql-typed-Version:       0.3.1+Version:       0.3.2 Cabal-Version: >= 1.8 License:       BSD3 License-File:  COPYING Copyright:     2010-2013 Chris Forno, 2014-2015 Dylan Simon Author:        Dylan Simon-Maintainer:    dylan@dylex.net+Maintainer:    Dylan Simon <dylan-pgtyped@dylex.net> Stability:     alpha Bug-Reports:   https://github.com/dylex/postgresql-typed/issues Homepage:      https://github.com/dylex/postgresql-typed@@ -46,7 +46,11 @@ Library   Build-Depends:     base >= 4.7 && < 5,-    array, binary, containers, old-locale, time,+    array,+    binary,+    containers < 0.5.6,+    old-locale,+    time < 1.5,     bytestring >= 0.10.2,     template-haskell,     haskell-src-meta,@@ -62,6 +66,7 @@     Database.PostgreSQL.Typed.Enum     Database.PostgreSQL.Typed.Array     Database.PostgreSQL.Typed.Range+    Database.PostgreSQL.Typed.Inet     Database.PostgreSQL.Typed.Dynamic     Database.PostgreSQL.Typed.TemplatePG   Other-Modules:
test/Main.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, DataKinds #-}+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, DataKinds, DeriveDataTypeable #-} -- {-# OPTIONS_GHC -ddump-splices #-} module Main (main) where @@ -45,7 +45,7 @@       d = Time.localDay t       p = -34881559 :: Time.DiffTime       s = "\"hel\\o'"-      l = [Just "a\\\"b,c", Nothing]+      l = [Just "a\\\"b,c", Nothing, Just "null", Just "nullish"]       r = Range.normal (Just (-2 :: Int32)) Nothing       e = MyEnum_XX_ye   [(Just b', Just i', Just f', Just s', Just d', Just t', Just z', Just p', Just l', Just r', Just e')] <- pgQuery c@@ -60,6 +60,8 @@   ["line"] <- preparedApply c 628    assert $ [pgSQL|#abc${f}def|] == "abc3.14::realdef"++  assert $ pgEnumValues == [(MyEnum_abc, "abc"), (MyEnum_DEF, "DEF"), (MyEnum_XX_ye, "XX_ye")]    pgDisconnect c   exitSuccess