packages feed

postgresql-typed 0.3.2 → 0.3.3

raw patch · 7 files changed

+119/−26 lines, 7 filesdep +aesondep +attoparsec

Dependencies added: aeson, attoparsec

Files

Database/PostgreSQL/Typed/Protocol.hs view
@@ -11,7 +11,7 @@   , defaultPGDatabase   , PGConnection   , PGError(..)-  , pgMessageCode+  , pgErrorCode   , pgTypeEnv   , pgConnect   , pgDisconnect@@ -170,7 +170,7 @@  -- |PGException is thrown upon encountering an 'ErrorResponse' with severity of --  ERROR, FATAL, or PANIC. It holds the message of the error.-data PGError = PGError MessageFields+data PGError = PGError { pgErrorFields :: MessageFields }   deriving (Typeable)  instance Show PGError where@@ -188,8 +188,8 @@  -- |Message SQLState code. --  See <http://www.postgresql.org/docs/current/static/errcodes-appendix.html>.-pgMessageCode :: MessageFields -> String-pgMessageCode = Map.findWithDefault "" 'C'+pgErrorCode :: PGError -> String+pgErrorCode (PGError e) = Map.findWithDefault "" 'C' e  defaultLogMessage :: MessageFields -> IO () defaultLogMessage = hPutStrLn stderr . displayMessage
Database/PostgreSQL/Typed/Query.hs view
@@ -94,6 +94,8 @@  instance IsString (PGSimpleQuery PGValues) where   fromString = rawPGSimpleQuery+instance IsString (PGSimpleQuery ()) where+  fromString = fmap (const ()) . rawPGSimpleQuery  -- |Make a prepared query directly from a query string and bind parameters, with no type inference rawPGPreparedQuery :: String -> PGValues -> PGPreparedQuery PGValues
Database/PostgreSQL/Typed/Range.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, UndecidableInstances, FunctionalDependencies, DataKinds #-}+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, UndecidableInstances, FunctionalDependencies, DataKinds, GeneralizedNewtypeDeriving, PatternGuards #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module: Database.PostgreSQL.Typed.Range@@ -14,45 +14,66 @@ import Control.Monad (guard) import qualified Data.ByteString.Builder as BSB import qualified Data.ByteString.Char8 as BSC-import Data.Monoid ((<>), mempty)+import Data.Monoid (Monoid(..), (<>)) import qualified Text.Parsec as P  import Database.PostgreSQL.Typed.Types +-- |A end-point for a range, which may be nothing (infinity, NULL in PostgreSQL), open (inclusive), or closed (exclusive) data Bound a-  = Unbounded-  | Bounded Bool a+  = Unbounded -- ^ Equivalent to @Bounded False ±Infinity@+  | Bounded+    { _boundClosed :: Bool -- ^ @True@ if the range includes this bound+    , _bound :: a+    }   deriving (Eq)  instance Functor Bound where   fmap _ Unbounded = Unbounded   fmap f (Bounded c a) = Bounded c (f a) -newtype LowerBound a = Lower (Bound a) deriving (Eq)--instance Functor LowerBound where-  fmap f (Lower b) = Lower (fmap f b)+newtype LowerBound a = Lower { boundLower :: Bound a } deriving (Eq, Functor) +-- |Takes into account open vs. closed (but does not understand equivalent discrete bounds) instance Ord a => Ord (LowerBound a) where   compare (Lower Unbounded) (Lower Unbounded) = EQ   compare (Lower Unbounded) _ = LT   compare _ (Lower Unbounded) = GT   compare (Lower (Bounded ac a)) (Lower (Bounded bc b)) = compare a b <> compare bc ac -newtype UpperBound a = Upper (Bound a) deriving (Eq)+-- |The constraint is only necessary for @maxBound@, unfortunately+instance Bounded a => Bounded (LowerBound a) where+  minBound = Lower Unbounded+  maxBound = Lower (Bounded False maxBound) -instance Functor UpperBound where-  fmap f (Upper b) = Upper (fmap f b)+newtype UpperBound a = Upper { boundUpper :: Bound a } deriving (Eq, Functor) +-- |Takes into account open vs. closed (but does not understand equivalent discrete bounds) instance Ord a => Ord (UpperBound a) where   compare (Upper Unbounded) (Upper Unbounded) = EQ   compare (Upper Unbounded) _ = GT   compare _ (Upper Unbounded) = LT   compare (Upper (Bounded ac a)) (Upper (Bounded bc b)) = compare a b <> compare ac bc +-- |The constraint is only necessary for @minBound@, unfortunately+instance Bounded a => Bounded (UpperBound a) where+  minBound = Upper (Bounded False minBound)+  maxBound = Upper Unbounded++compareBounds :: Ord a => LowerBound a -> UpperBound a -> Bound Bool+compareBounds (Lower (Bounded lc l)) (Upper (Bounded uc u)) =+  case compare l u of+    LT -> Bounded True True+    EQ -> Bounded (lc /= uc) (lc && uc)+    GT -> Bounded False False+compareBounds _ _ = Unbounded+ data Range a   = Empty-  | Range (LowerBound a) (UpperBound a)+  | Range+    { lower :: LowerBound a+    , upper :: UpperBound a+    }   deriving (Eq)  instance Functor Range where@@ -70,28 +91,45 @@ bound Unbounded = Nothing bound (Bounded _ b) = Just b +-- |Unbounded endpoints are always open. boundClosed :: Bound a -> Bool boundClosed Unbounded = False boundClosed (Bounded c _) = c +-- |Construct from parts: @makeBound (boundClosed b) (bound b) == b@ makeBound :: Bool -> Maybe a -> Bound a makeBound c (Just a) = Bounded c a makeBound False Nothing = Unbounded makeBound True Nothing = error "makeBound: unbounded may not be closed" +-- |Empty ranges treated as 'Unbounded'+lowerBound :: Range a -> Bound a+lowerBound Empty = Unbounded+lowerBound (Range (Lower b) _) = b++-- |Empty ranges treated as 'Unbounded'+upperBound :: Range a -> Bound a+upperBound Empty = Unbounded+upperBound (Range _ (Upper b)) = b++-- |Equivalent to @boundClosed . lowerBound@ lowerClosed :: Range a -> Bool lowerClosed Empty = False lowerClosed (Range (Lower b) _) = boundClosed b +-- |Equivalent to @boundClosed . upperBound@ upperClosed :: Range a -> Bool upperClosed Empty = False upperClosed (Range _ (Upper b)) = boundClosed b +empty :: Range a+empty = Empty+ isEmpty :: Ord a => Range a -> Bool isEmpty Empty = True-isEmpty (Range (Lower (Bounded True l)) (Upper (Bounded True u))) = l > u-isEmpty (Range (Lower (Bounded _ l)) (Upper (Bounded _ u))) = l >= u-isEmpty _ = False+isEmpty (Range l u)+  | Bounded _ n <- compareBounds l u = not n+  | otherwise = False  full :: Range a full = Range (Lower Unbounded) (Upper Unbounded)@@ -100,23 +138,29 @@ isFull (Range (Lower Unbounded) (Upper Unbounded)) = True isFull _ = False +-- |Create a point range @[x,x]@ point :: Eq a => a -> Range a point a = Range (Lower (Bounded True a)) (Upper (Bounded True a)) +-- |Extract a point: @getPoint (point x) == Just x@ getPoint :: Eq a => Range a -> Maybe a getPoint (Range (Lower (Bounded True l)) (Upper (Bounded True u))) = u <$ guard (u == l) getPoint _ = Nothing +-- Construct a range from endpoints and normalize it. range :: Ord a => Bound a -> Bound a -> Range a range l u = normalize $ Range (Lower l) (Upper u) +-- Construct a standard range (@[l,u)@ or 'point') from bounds (like 'bound') and normalize it. normal :: Ord a => Maybe a -> Maybe a -> Range a-normal l u = range (mb True l) (mb False u) where+normal l u = range (mb True l) (mb (l == u) u) where   mb = maybe Unbounded . Bounded +-- Construct a bounded range like 'normal'. bounded :: Ord a => a -> a -> Range a-bounded l u = range (Bounded True l) (Bounded False u)+bounded l u = normal (Just l) (Just u) +-- Fold empty ranges to 'Empty'. normalize :: Ord a => Range a -> Range a normalize r   | isEmpty r = Empty@@ -125,7 +169,7 @@ -- |'normalize' for discrete (non-continuous) range types, using the 'Enum' instance normalize' :: (Ord a, Enum a) => Range a -> Range a normalize' Empty = Empty-normalize' (Range (Lower l) (Upper u)) = range l' u'+normalize' (Range (Lower l) (Upper u)) = normalize $ range l' u'   where   l' = case l of     Bounded False b -> Bounded True (succ b)@@ -134,18 +178,35 @@     Bounded True b -> Bounded False (succ b)     _ -> l +-- |Contains range (@>), (<@) :: Ord a => Range a -> Range a -> Bool _ @> Empty = True Empty @> r = isEmpty r Range la ua @> Range lb ub = la <= lb && ua >= ub a <@ b = b @> a +-- |Contains element (@>.) :: Ord a => Range a -> a -> Bool r @>. a = r @> point a +overlaps :: Ord a => Range a -> Range a -> Bool+overlaps a b = intersect a b /= Empty+ intersect :: Ord a => Range a -> Range a -> Range a intersect (Range la ua) (Range lb ub) = normalize $ Range (max la lb) (min ua ub) intersect _ _ = Empty++instance Ord a => Monoid (Range a) where+  mempty = Empty+  -- |Union ranges.  Fails if ranges are disjoint.+  mappend Empty r = r+  mappend r Empty = r+  mappend _ra@(Range la ua) _rb@(Range lb ub)+    -- isEmpty _ra = _rb+    -- isEmpty _rb = _ra+    | Bounded False False <- compareBounds lb ua = error "mappend: disjoint Ranges"+    | Bounded False False <- compareBounds la ub = error "mappend: disjoint Ranges"+    | otherwise = Range (min la lb) (max ua ub)   -- |Class indicating that the first PostgreSQL type is a range of the second.
Database/PostgreSQL/Typed/TH.hs view
@@ -151,7 +151,7 @@       { tpgValueName = c       , tpgValueTypeOID = o       , tpgValueType = tpgType tpg o-      , tpgValueNullable = n+      , tpgValueNullable = n && o /= 2278 -- "void"       }) rt     )
Database/PostgreSQL/Typed/TemplatePG.hs view
@@ -87,7 +87,7 @@ -- |Ignore duplicate key errors. This is also limited to the 'IO' Monad. insertIgnore :: IO () -> IO () insertIgnore q = catchJust uniquenessError q (\ _ -> return ()) where-  uniquenessError (PG.PGError m) = guard (PG.pgMessageCode m == "24505")+  uniquenessError e = guard (PG.pgErrorCode e == "23505")  type PGException = PG.PGError
Database/PostgreSQL/Typed/Types.hs view
@@ -36,6 +36,10 @@  import Control.Applicative ((<$>), (<$)) import Control.Monad (mzero)+#ifdef USE_AESON+import qualified Data.Aeson as JSON+import qualified Data.Attoparsec.ByteString as JSONP+#endif import Data.Bits (shiftL, (.|.)) import Data.ByteString.Internal (w2c) import qualified Data.ByteString as BS@@ -215,6 +219,12 @@ #define BIN_DEC(F) #endif +instance PGType "void"+instance PGColumn "void" () where+  pgDecode _ _ = ()+  pgDecodeBinary _ _ _ = ()+  pgDecodeValue _ _ _ = ()+ instance PGType "boolean" where BIN_COL instance PGParameter "boolean" Bool where   pgEncode _ False = BSC.singleton 'f'@@ -565,8 +575,21 @@ -- In this case we can not know the types, and in fact, PostgreSQL does not accept values of this type regardless (except as literals). instance PGRecordType "record" +#ifdef USE_AESON+instance PGType "json"+instance PGParameter "json" JSON.Value where+  pgEncode _ = BSL.toStrict . JSON.encode+instance PGColumn "json" JSON.Value where+  pgDecode _ j = either (error . ("pgDecode json: " ++)) id $ JSONP.parseOnly JSON.json j++instance PGType "jsonb"+instance PGParameter "jsonb" JSON.Value where+  pgEncode _ = BSL.toStrict . JSON.encode+instance PGColumn "jsonb" JSON.Value where+  pgDecode _ j = either (error . ("pgDecode json: " ++)) id $ JSONP.parseOnly JSON.json j+#endif+ {----, ( 114,  199, "json",        ?) --, ( 142,  143, "xml",         ?) --, ( 600, 1017, "point",       ?) --, ( 650,  651, "cidr",        ?)
postgresql-typed.cabal view
@@ -1,5 +1,5 @@ Name:          postgresql-typed-Version:       0.3.2+Version:       0.3.3 Cabal-Version: >= 1.8 License:       BSD3 License-File:  COPYING@@ -43,6 +43,10 @@   Description: Support decoding numeric via scientific (implied by binary).   Default: True +Flag aeson+  Description: Support decoding json via aeson.+  Default: True+ Library   Build-Depends:     base >= 4.7 && < 5,@@ -88,6 +92,9 @@     if flag(scientific)       Build-Depends: scientific >= 0.3       CPP-options: -DUSE_SCIENTIFIC+  if flag(aeson)+    Build-Depends: aeson >= 0.7, attoparsec >= 0.10+    CPP-options: -DUSE_AESON  test-suite test   build-depends: base, network, time, postgresql-typed