hpqtypes-extras 1.4.0.0 → 1.5.0.0

raw patch · 5 files changed

+121/−16 lines, 5 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +5/−0
• hpqtypes-extras.cabal +2/−1
• src/Database/PostgreSQL/PQTypes/Checks.hs +42/−9
• src/Database/PostgreSQL/PQTypes/Model/PrimaryKey.hs +6/−6
• src/Database/PostgreSQL/PQTypes/Utils/NubList.hs +66/−0

@@ -1,3 +1,8 @@+# hpqtypes-extras-1.5.0.0 (2017-12-08)+* Changed internal representation of PrimaryKey to NubList (#11)+  This will break existing PKs set on multiple columns unless they are+  alphabetically sorted in the defining list.+ # hpqtypes-extras-1.4.0.0 (2017-11-24) * Introduced tsvector postgres type and indexing methods GIN and BTree 

@@ -1,5 +1,5 @@ name:                hpqtypes-extras-version:             1.4.0.0+version:             1.5.0.0 synopsis:            Extra utilities for hpqtypes library description:         The following extras for hpqtypes library:                      .@@ -47,6 +47,7 @@                  , Database.PostgreSQL.PQTypes.SQL.Builder                  , Database.PostgreSQL.PQTypes.Versions   other-modules:   Database.PostgreSQL.PQTypes.Checks.Util+                 , Database.PostgreSQL.PQTypes.Utils.NubList    build-depends: base < 5                , base16-bytestring

@@ -19,6 +19,7 @@ import Data.Monoid import Data.Monoid.Utils import Data.Ord (comparing)+import qualified Data.String import Data.Text (Text) import Database.PostgreSQL.PQTypes hiding (def) import Log@@ -297,8 +298,7 @@         sqlOrderBy "a.attnum"       desc <- fetchMany fetchTableColumn       -- get info about constraints from pg_catalog-      runQuery_ $ sqlGetPrimaryKey table-      pk <- join <$> fetchMaybe fetchPrimaryKey+      pk <- sqlGetPrimaryKey table       runQuery_ $ sqlGetChecks table       checks <- fetchMany fetchTableCheck       runQuery_ $ sqlGetIndexes table@@ -788,13 +788,46 @@  -- *** PRIMARY KEY *** -sqlGetPrimaryKey :: Table -> SQL-sqlGetPrimaryKey table = toSQLCommand . sqlSelect "pg_catalog.pg_constraint c" $ do-  sqlResult "c.conname::text"-  -- list of affected columns-  sqlResult "array(SELECT a.attname::text FROM pg_catalog.pg_attribute a WHERE a.attrelid = c.conrelid AND a.attnum = ANY (c.conkey)) as columns"-  sqlWhereEq "c.contype" 'p'-  sqlWhereEqSql "c.conrelid" $ sqlGetTableID table+sqlGetPrimaryKey :: (MonadDB m, MonadThrow m) => Table -> m (Maybe (PrimaryKey, RawSQL ()))+sqlGetPrimaryKey table = do++  (mColumnNumbers :: Maybe [Int16]) <- do+    runQuery_ . sqlSelect "pg_catalog.pg_constraint" $ do+      sqlResult "conkey"+      sqlWhereEqSql "conrelid" (sqlGetTableID table)+      sqlWhereEq "contype" 'p'+    fetchMaybe $ unArray1 . runIdentity++  case mColumnNumbers of+    Nothing -> do return Nothing+    Just columnNumbers -> do+      columnNames <- do+        forM columnNumbers $ \k -> do+          runQuery_ . sqlSelect "pk_columns" $ do++            sqlWith "key_series" . sqlSelect "pg_constraint as c2" $ do+              sqlResult "unnest(c2.conkey) as k"+              sqlWhereEqSql "c2.conrelid" $ sqlGetTableID table+              sqlWhereEq "c2.contype" 'p'++            sqlWith "pk_columns" . sqlSelect "key_series" $ do+              sqlJoinOn  "pg_catalog.pg_attribute as a" "a.attnum = key_series.k"+              sqlResult "a.attname::text as column_name"+              sqlResult "key_series.k as column_order"+              sqlWhereEqSql "a.attrelid" $ sqlGetTableID table++            sqlResult "pk_columns.column_name"+            sqlWhereEq "pk_columns.column_order" k++          fetchOne (\(Identity t) -> t :: String)++      runQuery_ . sqlSelect "pg_catalog.pg_constraint as c" $ do+        sqlWhereEq "c.contype" 'p'+        sqlWhereEqSql "c.conrelid" $ sqlGetTableID table+        sqlResult "c.conname::text"+        sqlResult $ Data.String.fromString ("array['" <> (mintercalate "', '" columnNames) <> "']::text[]")++      join <$> fetchMaybe fetchPrimaryKey  fetchPrimaryKey :: (String, Array1 String) -> Maybe (PrimaryKey, RawSQL ()) fetchPrimaryKey (name, Array1 columns) = (, unsafeSQL name)

@@ -11,17 +11,17 @@ import Data.Monoid.Utils import Database.PostgreSQL.PQTypes import Prelude-import qualified Data.Set as S+import Database.PostgreSQL.PQTypes.Utils.NubList -newtype PrimaryKey = PrimaryKey (S.Set (RawSQL ()))-  deriving (Eq, Ord, Show)+newtype PrimaryKey = PrimaryKey (NubList (RawSQL ()))+  deriving (Eq, Show)  pkOnColumn :: RawSQL () -> Maybe PrimaryKey-pkOnColumn = Just . PrimaryKey . S.singleton+pkOnColumn column = Just . PrimaryKey . toNubList $ [column]  pkOnColumns :: [RawSQL ()] -> Maybe PrimaryKey pkOnColumns []      = Nothing-pkOnColumns columns = Just . PrimaryKey . S.fromList $ columns+pkOnColumns columns = Just . PrimaryKey . toNubList $ columns  pkName :: RawSQL () -> RawSQL () pkName tname = mconcat ["pk__", tname]@@ -31,7 +31,7 @@     "ADD CONSTRAINT"   , pkName tname   , "PRIMARY KEY ("-  , mintercalate ", " $ S.toAscList columns+  , mintercalate ", " $ fromNubList columns   , ")"   ] 

@@ -0,0 +1,66 @@+{-# LANGUAGE DeriveDataTypeable #-}+module Database.PostgreSQL.PQTypes.Utils.NubList+    ( NubList    -- opaque+    , toNubList  -- smart construtor+    , fromNubList+    , overNubList+    ) where++import Prelude+import Data.Monoid (Monoid(..))+import Data.Typeable++import qualified Text.Read as R+import qualified Data.Set as Set++{-+  This module is a copy-paste fork of Distribution.Utils.NubList in Cabal+  (Cabal-2.0.1.1 as it happens) to avoid depending on the whole of the Cabal+  library. `NubListR` was removed in the process and `ordNubBy` and `listUnion`+  hand-inlined to avoid depending on more Cabal-specific modules.+-}++-- | NubList : A de-duplicated list that maintains the original order.+newtype NubList a =+    NubList { fromNubList :: [a] }+    deriving (Eq, Typeable)++-- NubList assumes that nub retains the list order while removing duplicate+-- elements (keeping the first occurence). Documentation for "Data.List.nub"+-- does not specifically state that ordering is maintained so we will add a test+-- for that to the test suite.++-- | Smart constructor for the NubList type.+toNubList :: Ord a => [a] -> NubList a+toNubList list = NubList $ (ordNubBy id) list++-- | Lift a function over lists to a function over NubLists.+overNubList :: Ord a => ([a] -> [a]) -> NubList a -> NubList a+overNubList f (NubList list) = toNubList . f $ list++instance Ord a => Monoid (NubList a) where+    mempty = NubList []+    (NubList xs) `mappend` (NubList ys) = NubList $ xs `listUnion` ys+      where listUnion :: (Ord a) => [a] -> [a] -> [a]+            listUnion a b = a ++ (ordNubBy id) (filter (`Set.notMember` (Set.fromList a)) b)++instance Show a => Show (NubList a) where+    show (NubList list) = show list++instance (Ord a, Read a) => Read (NubList a) where+    readPrec = readNubList toNubList++-- | Helper used by NubList/NubListR's Read instances.+readNubList :: (Read a) => ([a] -> l a) -> R.ReadPrec (l a)+readNubList toList = R.parens . R.prec 10 $ fmap toList R.readPrec++ordNubBy :: Ord b => (a -> b) -> [a] -> [a]+ordNubBy f l = go Set.empty l+  where+    go !_ [] = []+    go !s (x:xs)+      | y `Set.member` s = go s xs+      | otherwise        = let !s' = Set.insert y s+                            in x : go s' xs+      where+        y = f x