From fd1ae0eb2284914bd2db92ee808f492e24b39a5a Mon Sep 17 00:00:00 2001 From: Jan Synacek Date: Fri, 29 Sep 2023 09:57:56 +0200 Subject: [PATCH] Hlint sources (#100) --- .github/workflows/hlint.yaml | 34 ++++++++++ src/Database/PostgreSQL/PQTypes/Checks.hs | 67 +++++++++---------- src/Database/PostgreSQL/PQTypes/Migrate.hs | 8 +-- .../PostgreSQL/PQTypes/SQL/Builder.hs | 5 +- .../PostgreSQL/PQTypes/Utils/NubList.hs | 2 +- test/Main.hs | 48 ++++++------- 6 files changed, 97 insertions(+), 67 deletions(-) create mode 100644 .github/workflows/hlint.yaml diff --git a/.github/workflows/hlint.yaml b/.github/workflows/hlint.yaml new file mode 100644 index 0000000..9b318ad --- /dev/null +++ b/.github/workflows/hlint.yaml @@ -0,0 +1,34 @@ +name: Hlint + +on: + pull_request: + paths: + - "**.hs" + - .github/workflows/hlint.yaml + push: + paths: + - "**.hs" + - .github/workflows/hlint.yaml + branches: + - master + +concurrency: + group: hpqtypes-extras-hlint-${{ github.ref_name }} + cancel-in-progress: true + +jobs: + hlint: + runs-on: + - ubuntu-22.04 + steps: + # v3.5.3 + - uses: actions/checkout@c85c95e3d7251135ab7dc9ce3241c5835cc595a9 + # v2.4.6 + - uses: haskell/actions/hlint-setup@a99601b177e00b98c78b6f6de680a101cf1c619d + with: + version: 3.6.1 + # v2.4.6 + - uses: haskell/actions/hlint-run@a99601b177e00b98c78b6f6de680a101cf1c619d + with: + path: ./ + fail-on: warning diff --git a/src/Database/PostgreSQL/PQTypes/Checks.hs b/src/Database/PostgreSQL/PQTypes/Checks.hs index 82b0d47..238e061 100644 --- a/src/Database/PostgreSQL/PQTypes/Checks.hs +++ b/src/Database/PostgreSQL/PQTypes/Checks.hs @@ -24,7 +24,6 @@ import Data.Function import Data.List (partition) import Data.Maybe import Data.Monoid.Utils -import Data.Ord (comparing) import Data.Typeable (cast) import qualified Data.String import Data.Text (Text) @@ -113,8 +112,7 @@ checkDatabase options composites domains tables = do where checkInitialSetups :: [Table] -> m ValidationResult - checkInitialSetups tbls = - liftM mconcat . mapM checkInitialSetup' $ tbls + checkInitialSetups = fmap mconcat . mapM checkInitialSetup' checkInitialSetup' :: Table -> m ValidationResult checkInitialSetup' t@Table{..} = case tblInitialSetup of @@ -159,7 +157,7 @@ setDBTimeZoneToUTC = do <> "' database to return timestamps in UTC" runQuery_ $ "ALTER DATABASE" <+> dbname <+> "SET TIMEZONE = 'UTC'" -- Setting the database timezone doesn't change the session timezone. - runSQL_ $ "SET timezone = 'UTC'" + runSQL_ "SET timezone = 'UTC'" -- | Get the names of all user-defined tables that actually exist in -- the DB. @@ -172,9 +170,7 @@ getDBTableNames = do sqlWhereExists $ sqlSelect "unnest(current_schemas(false)) as cs" $ do sqlResult "TRUE" sqlWhere "cs = table_schema" - - dbTableNames <- fetchMany runIdentity - return dbTableNames + fetchMany runIdentity checkVersions :: ExtrasOptions -> TablesWithVersions -> ValidationResult checkVersions options = mconcat . map checkVersion @@ -205,8 +201,8 @@ checkUnknownTables tables = do mapM_ (logInfo_ . (<+>) "Unknown table:") absent mapM_ (logInfo_ . (<+>) "Table not present in the database:") notPresent return $ - (validateIsNull "Unknown tables:" absent) <> - (validateIsNull "Tables not present in the database:" notPresent) + validateIsNull "Unknown tables:" absent <> + validateIsNull "Tables not present in the database:" notPresent else return mempty validateIsNull :: Text -> [Text] -> ValidationResult @@ -233,8 +229,8 @@ checkExistenceOfVersionsForTables tables = do mapM_ (logInfo_ . (<+>) "Table not present in the 'table_versions':") notPresent return $ - (validateIsNull "Unknown entry in table_versions':" absent ) <> - (validateIsNull "Tables not present in the 'table_versions':" notPresent) + validateIsNull "Unknown entry in table_versions':" absent <> + validateIsNull "Tables not present in the 'table_versions':" notPresent else return mempty @@ -447,7 +443,7 @@ checkDBStructure options tables = fmap mconcat . forM tables $ \(table, version) , colType = ctype , colCollation = flip rawSQL () <$> collation , colNullable = nullable - , colDefault = unsafeSQL `liftM` mdefault + , colDefault = unsafeSQL <$> mdefault } checkColumns @@ -467,8 +463,8 @@ checkDBStructure options tables = fmap mconcat . forM tables $ \(table, version) -- sequences as they're implicitly specified by db, so -- let's omit them in such case. , validateDefaults $ colDefault d == colDefault c || - (colDefault d == Nothing - && ((T.isPrefixOf "nextval('" . unRawSQL) `liftM` colDefault c) + (isNothing (colDefault d) + && (T.isPrefixOf "nextval('" . unRawSQL <$> colDefault c) == Just True) , validateNullables $ colNullable d == colNullable c , checkColumns (n+1) defs cols @@ -491,7 +487,7 @@ checkDBStructure options tables = fmap mconcat . forM tables $ \(table, version) validateDefaults True = mempty validateDefaults False = validationError $ - (errorMsg cname "defaults" (showt . fmap unRawSQL . colDefault)) + errorMsg cname "defaults" (showt . fmap unRawSQL . colDefault) <+> sqlHint set_default where set_default = case colDefault d of @@ -512,7 +508,7 @@ checkDBStructure options tables = fmap mconcat . forM tables $ \(table, version) checkPrimaryKey mdef mpk = mconcat [ checkEquality "PRIMARY KEY" def (map fst pk) , checkNames (const (pkName tblName)) pk - , if (eoEnforcePKs options) + , if eoEnforcePKs options then checkPKPresence tblName mdef mpk else mempty ] @@ -638,7 +634,7 @@ checkDBConsistency options domains tablesWithVersions migrations = do errorInvalidMigrations :: HasCallStack => [RawSQL ()] -> a errorInvalidMigrations tblNames = error $ "checkDBConsistency: invalid migrations for tables" - <+> (L.intercalate ", " $ map (T.unpack . unRawSQL) tblNames) + <+> L.intercalate ", " (map (T.unpack . unRawSQL) tblNames) checkMigrationsListValidity :: Table -> [Int32] -> [Int32] -> m () checkMigrationsListValidity table presentMigrationVersions @@ -649,7 +645,7 @@ checkDBConsistency options domains tablesWithVersions migrations = do , "migration_versions" .= presentMigrationVersions , "expected_migration_versions" .= expectedMigrationVersions ] - errorInvalidMigrations [tblName $ table] + errorInvalidMigrations [tblName table] validateMigrations :: m () validateMigrations = forM_ tables $ \table -> do @@ -666,15 +662,15 @@ checkDBConsistency options domains tablesWithVersions migrations = do validateDropTableMigrations :: m () validateDropTableMigrations = do let droppedTableNames = - [ mgrTableName $ mgr | mgr <- migrations - , isDropTableMigration mgr ] + [ mgrTableName mgr | mgr <- migrations + , isDropTableMigration mgr ] tableNames = [ tblName tbl | tbl <- tables ] -- Check that the intersection between the 'tables' list and -- dropped tables is empty. let intersection = L.intersect droppedTableNames tableNames - when (not . null $ intersection) $ do + unless (null intersection) $ do logAttention ("The intersection between tables " <> "and dropped tables is not empty") $ object @@ -695,7 +691,7 @@ checkDBConsistency options domains tablesWithVersions migrations = do , (not . isDropTableMigration . last $ mgrs) || (length . filter isDropTableMigration $ mgrs) > 1 ] - when (not . null $ invalidMigrationLists) $ do + unless (null invalidMigrationLists) $ do let tablesWithInvalidMigrationLists = [ mgrTableName mgr | mgrs <- invalidMigrationLists , let mgr = head mgrs ] @@ -754,7 +750,7 @@ checkDBConsistency options domains tablesWithVersions migrations = do | mgr <- migrations , isDropTableMigration mgr , let tblName = mgrTableName mgr - , let mver = lookup (unRawSQL tblName) $ dbTablesWithVersions + , let mver = lookup (unRawSQL tblName) dbTablesWithVersions , isJust mver ] forM_ dbTablesToDropWithVersions $ \(tblName, fromVer, ver) -> when (fromVer /= ver) $ @@ -790,8 +786,7 @@ checkDBConsistency options domains tablesWithVersions migrations = do (not . droppedEventually $ mgr) -- Table exists in the DB. Run only those migrations -- that have mgrFrom >= table version in the DB. - Just ver -> not $ - mgrFrom mgr >= ver) + Just ver -> mgrFrom mgr < ver) migrations -- Special case: also include migrations for tables that do @@ -825,7 +820,7 @@ checkDBConsistency options domains tablesWithVersions migrations = do else [] in migrationsToRun - runMigration :: (Migration m) -> m () + runMigration :: Migration m -> m () runMigration Migration{..} = do case mgrAction of StandardMigration mgrDo -> do @@ -933,7 +928,7 @@ checkDBConsistency options domains tablesWithVersions migrations = do runMigrations dbTablesWithVersions = do let migrationsToRun = findMigrationsToRun dbTablesWithVersions validateMigrationsToRun migrationsToRun dbTablesWithVersions - when (not . null $ migrationsToRun) $ do + unless (null migrationsToRun) $ do logInfo_ "Running migrations..." forM_ migrationsToRun $ \mgr -> fix $ \loop -> do let restartMigration query = do @@ -945,7 +940,7 @@ checkDBConsistency options domains tablesWithVersions migrations = do forM_ (eoLockTimeoutMs options) $ \lockTimeout -> do runSQL_ $ "SET LOCAL lock_timeout TO" <+> intToSQL lockTimeout runMigration mgr `onException` rollback - logInfo_ $ "Committing migration changes..." + logInfo_ "Committing migration changes..." commit logInfo_ "Running migrations... done." where @@ -964,7 +959,7 @@ checkDBConsistency options domains tablesWithVersions migrations = do let migrationsToRunGrouped :: [[Migration m]] migrationsToRunGrouped = L.groupBy ((==) `on` mgrTableName) . - L.sortBy (comparing mgrTableName) $ -- NB: stable sort + L.sortOn mgrTableName $ -- NB: stable sort migrationsToRun loc_common = "Database.PostgreSQL.PQTypes.Checks." @@ -1021,7 +1016,7 @@ checkDBConsistency options domains tablesWithVersions migrations = do where head_err = loc_common ++ ".tblNames: broken invariant" - when (not . null $ groupsWithWrongDBTableVersions) $ do + unless (null groupsWithWrongDBTableVersions) $ do let tnms = tblNames . map fst $ groupsWithWrongDBTableVersions logAttention ("There are migration chains selected for execution " @@ -1031,14 +1026,14 @@ checkDBConsistency options domains tablesWithVersions migrations = do $ object [ "tables" .= map unRawSQL tnms ] errorInvalidMigrations tnms - when (not . null $ groupsStartingWithDropTable) $ do + unless (null groupsStartingWithDropTable) $ do let tnms = tblNames groupsStartingWithDropTable logAttention "There are drop table migrations for non-existing tables." $ object [ "tables" .= map unRawSQL tnms ] errorInvalidMigrations tnms -- NB: the following check can break if we allow renaming tables. - when (not . null $ groupsNotStartingWithCreateTable) $ do + unless (null groupsNotStartingWithCreateTable) $ do let tnms = tblNames groupsNotStartingWithCreateTable logAttention ("Some tables haven't been created yet, but" <> @@ -1078,7 +1073,7 @@ checkTableVersion tblName = do doesExist <- runQuery01 . sqlSelect "pg_catalog.pg_class c" $ do sqlResult "TRUE" sqlLeftJoinOn "pg_catalog.pg_namespace n" "n.oid = c.relnamespace" - sqlWhereEq "c.relname" $ tblName + sqlWhereEq "c.relname" tblName sqlWhere "pg_catalog.pg_table_is_visible(c.oid)" if doesExist then do @@ -1146,13 +1141,13 @@ sqlGetPrimaryKey table = do sqlWhereEqSql "c.conrelid" $ sqlGetTableID table sqlResult "c.conname::text" sqlResult $ Data.String.fromString - ("array['" <> (mintercalate "', '" columnNames) <> "']::text[]") + ("array['" <> mintercalate "', '" columnNames <> "']::text[]") join <$> fetchMaybe fetchPrimaryKey fetchPrimaryKey :: (String, Array1 String) -> Maybe (PrimaryKey, RawSQL ()) fetchPrimaryKey (name, Array1 columns) = (, unsafeSQL name) - <$> (pkOnColumns $ map unsafeSQL columns) + <$> pkOnColumns (map unsafeSQL columns) -- *** CHECKS *** @@ -1213,7 +1208,7 @@ fetchTableIndex (name, Array1 keyColumns, Array1 includeColumns, method, unique, , idxMethod = read method , idxUnique = unique , idxValid = valid - , idxWhere = unsafeSQL `liftM` mconstraint + , idxWhere = unsafeSQL <$> mconstraint } , unsafeSQL name) diff --git a/src/Database/PostgreSQL/PQTypes/Migrate.hs b/src/Database/PostgreSQL/PQTypes/Migrate.hs index a0d2333..6ce7b19 100644 --- a/src/Database/PostgreSQL/PQTypes/Migrate.hs +++ b/src/Database/PostgreSQL/PQTypes/Migrate.hs @@ -39,13 +39,11 @@ createTable withConstraints table@Table{..} = do sqlSet "version" tblVersion createTableConstraints :: MonadDB m => Table -> m () -createTableConstraints Table{..} = when (not $ null addConstraints) $ do +createTableConstraints Table{..} = unless (null addConstraints) $ do runQuery_ $ sqlAlterTable tblName addConstraints where - addConstraints = concat - [ map sqlAddValidCheckMaybeDowntime tblChecks - , map (sqlAddValidFKMaybeDowntime tblName) tblForeignKeys - ] + addConstraints = map sqlAddValidCheckMaybeDowntime tblChecks + ++ map (sqlAddValidFKMaybeDowntime tblName) tblForeignKeys createTableTriggers :: MonadDB m => Table -> m () createTableTriggers = mapM_ createTrigger . tblTriggers diff --git a/src/Database/PostgreSQL/PQTypes/SQL/Builder.hs b/src/Database/PostgreSQL/PQTypes/SQL/Builder.hs index b61c4c4..6626267 100644 --- a/src/Database/PostgreSQL/PQTypes/SQL/Builder.hs +++ b/src/Database/PostgreSQL/PQTypes/SQL/Builder.hs @@ -405,7 +405,7 @@ instance Sqlable SqlInsert where longest = maximum (1 : (map (lengthOfEither . snd) (sqlInsertSet cmd))) lengthOfEither (Single _) = 1 lengthOfEither (Many x) = length x - makeLongEnough (Single x) = take longest (repeat x) + makeLongEnough (Single x) = replicate longest x makeLongEnough (Many x) = take longest (x ++ repeat "DEFAULT") instance Sqlable SqlInsertSelect where @@ -448,6 +448,7 @@ withMaterializedSupported :: IORef Bool withMaterializedSupported = unsafePerformIO $ newIORef False isWithMaterializedSupported :: Bool +{-# NOINLINE isWithMaterializedSupported #-} isWithMaterializedSupported = unsafePerformIO $ readIORef withMaterializedSupported materializedClause :: Materialized -> SQL @@ -832,4 +833,4 @@ instance SqlDistinct SqlInsertSelect where sqlDistinct1 cmd = cmd { sqlInsertSelectDistinct = True } sqlDistinct :: (MonadState v m, SqlDistinct v) => m () -sqlDistinct = modify (\cmd -> sqlDistinct1 cmd) +sqlDistinct = modify sqlDistinct1 diff --git a/src/Database/PostgreSQL/PQTypes/Utils/NubList.hs b/src/Database/PostgreSQL/PQTypes/Utils/NubList.hs index 6e9f68c..d3bf5d9 100644 --- a/src/Database/PostgreSQL/PQTypes/Utils/NubList.hs +++ b/src/Database/PostgreSQL/PQTypes/Utils/NubList.hs @@ -59,7 +59,7 @@ 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 +ordNubBy f = go Set.empty where go !_ [] = [] go !s (x:xs) diff --git a/test/Main.hs b/test/Main.hs index 23dfd3a..35175a1 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# HLINT ignore "Use head" #-} module Main where import Control.Monad.Catch @@ -31,7 +33,7 @@ import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.Options -data ConnectionString = ConnectionString String +newtype ConnectionString = ConnectionString String deriving Typeable instance IsOption ConnectionString where @@ -104,8 +106,8 @@ tableBankMigration4 = Migration tableBankSchema4 :: Table tableBankSchema4 = tableBankSchema3 { - tblVersion = (tblVersion tableBankSchema3) + 1 - , tblColumns = (tblColumns tableBankSchema3) ++ [ + tblVersion = tblVersion tableBankSchema3 + 1 + , tblColumns = tblColumns tableBankSchema3 ++ [ tblColumn { colName = "cash", colType = IntegerT , colNullable = False @@ -121,7 +123,7 @@ tableBankMigration5fst = Migration , mgrFrom = 2 , mgrAction = StandardMigration $ do runQuery_ $ sqlAlterTable (tblName tableBankSchema4) [ - sqlDropColumn $ "cash" + sqlDropColumn "cash" ] } @@ -136,7 +138,7 @@ tableBankMigration5snd = Migration tableBankSchema5 :: Table tableBankSchema5 = tableBankSchema4 { - tblVersion = (tblVersion tableBankSchema4) + 2 + tblVersion = tblVersion tableBankSchema4 + 2 , tblColumns = filter (\c -> colName c /= "cash") (tblColumns tableBankSchema4) , tblIndexes = [(indexOnColumn "name") { idxInclude = ["id", "location"] }] @@ -428,7 +430,7 @@ schema6Tables = , tableBadGuySchema1 , tableRobberySchema1 , tableParticipatedInRobberySchema1 - { tblVersion = (tblVersion tableParticipatedInRobberySchema1) + 1, + { tblVersion = tblVersion tableParticipatedInRobberySchema1 + 1, tblPrimaryKey = Nothing } , tableWitnessSchema1 , tableWitnessedRobberySchema1 @@ -441,8 +443,8 @@ schema6Migrations = , mgrFrom = tblVersion tableParticipatedInRobberySchema1 , mgrAction = StandardMigration $ do - runQuery_ $ ("ALTER TABLE participated_in_robbery DROP CONSTRAINT \ - \pk__participated_in_robbery" :: RawSQL ()) + runQuery_ ("ALTER TABLE participated_in_robbery DROP CONSTRAINT \ + \pk__participated_in_robbery" :: RawSQL ()) } @@ -1172,7 +1174,7 @@ testTriggers step = do verify triggers present = do dbTriggers <- getDBTriggers "bank" let trgs = map fst dbTriggers - ok = and $ map (`elem` trgs) triggers + ok = all (`elem` trgs) triggers err = "Triggers " <> (if present then "" else "not ") <> "present in the database." trans = if present then id else not liftIO . assertBool err $ trans ok @@ -1217,8 +1219,8 @@ testSqlWith step = do migrate [tableBankSchema1] [createTableMigration tableBankSchema1] step "inserting initial data" runQuery_ . sqlInsert "bank" $ do - sqlSetList "name" (["HSBC" :: T.Text, "other"]) - sqlSetList "location" (["13 Foo St., Tucson" :: T.Text, "no address"]) + sqlSetList "name" ["HSBC" :: T.Text, "other"] + sqlSetList "location" ["13 Foo St., Tucson" :: T.Text, "no address"] sqlResult "id" step "testing WITH .. INSERT SELECT" runQuery_ . sqlInsertSelect "bank" "bank_name" $ do @@ -1337,16 +1339,16 @@ migrationTest2 connSource = checkDatabase extrasOptionsWithUnknownObjects [] [] currentSchema assertException "checkDatabase should throw exception for wrong schema" $ checkDatabase extrasOptions [] [] differentSchema - assertException ("checkDatabaseAllowUnknownObjects \ - \should throw exception for wrong scheme") $ + assertException "checkDatabaseAllowUnknownObjects \ + \should throw exception for wrong scheme" $ checkDatabase extrasOptionsWithUnknownObjects [] [] differentSchema runSQL_ "INSERT INTO table_versions (name, version) \ \VALUES ('unknown_table', 0)" assertException "checkDatabase throw when extra entry in 'table_versions'" $ checkDatabase extrasOptions [] [] currentSchema - assertNoException ("checkDatabaseAllowUnknownObjects \ - \accepts extra entry in 'table_versions'") $ + assertNoException "checkDatabaseAllowUnknownObjects \ + \accepts extra entry in 'table_versions'" $ checkDatabase extrasOptionsWithUnknownObjects [] [] currentSchema runSQL_ "DELETE FROM table_versions where name='unknown_table'" @@ -1360,8 +1362,8 @@ migrationTest2 connSource = \VALUES ('unknown_table', 0)" assertException "checkDatabase should throw with unknown table" $ checkDatabase extrasOptions [] [] currentSchema - assertNoException ("checkDatabaseAllowUnknownObjects \ - \accepts unknown tables with version") $ + assertNoException "checkDatabaseAllowUnknownObjects \ + \accepts unknown tables with version" $ checkDatabase extrasOptionsWithUnknownObjects [] [] currentSchema freshTestDB step @@ -1403,8 +1405,8 @@ migrationTest3 connSource = migrateDBToSchema2 step testDBSchema2 step badGuyIds robberyIds - assertException ( "Trying to run the same migration twice should fail, \ - \when starting with a createTable migration" ) $ + assertException "Trying to run the same migration twice should fail, \ + \when starting with a createTable migration" $ migrateDBToSchema2Hacky step freshTestDB step @@ -1659,14 +1661,14 @@ foreignKeyIndexesTests connSource = assertNoException :: String -> TestM () -> TestM () -assertNoException t c = eitherExc +assertNoException t = eitherExc (const $ liftIO $ assertFailure ("Exception thrown for: " ++ t)) - (const $ return ()) c + (const $ return ()) assertException :: String -> TestM () -> TestM () -assertException t c = eitherExc +assertException t = eitherExc (const $ return ()) - (const $ liftIO $ assertFailure ("No exception thrown for: " ++ t)) c + (const $ liftIO $ assertFailure ("No exception thrown for: " ++ t)) assertDBException :: String -> TestM () -> TestM () assertDBException t c =