Use haskell-dev-tools with ghc 9.4.7 (#1286)

* Update haskell-dev-tools and fourmolu config.

* New fourmolu changes

* WIP fix lint

* Fix a redundant import.

* Work around hlint bug where typed TH splices aren't recognized.

* Fix suppress error warnings from the cabal-install step.

* Move the cabal install check into the build-all workflow.

* Revert "Move the cabal install check into the build-all workflow."

This reverts commit f906793.

* Don't use the linux profile in cabal install check.

This means that we can pass -Wwarn successfully.

* Use sed to delete -Werror for cabal install check.

* Fix lint workflow format.

* Use GNU sed compatible options.

* Document the necessity of fixities.

.github/workflows/lint.yml

@@ -6,7 +6,7 @@ jobs:
   linter-check:
     name: linter-check
     runs-on: ubuntu-latest
-    container: ghcr.io/fossas/haskell-dev-tools:9.0.2
+    container: ghcr.io/fossas/haskell-dev-tools:9.4.7
 
     steps:
       - uses: actions-rs/toolchain@v1
@@ -41,7 +41,7 @@ jobs:
   format-check:
     name: formatter-check
     runs-on: ubuntu-latest
-    container: ghcr.io/fossas/haskell-dev-tools:9.0.2
+    container: ghcr.io/fossas/haskell-dev-tools:9.4.7
 
     steps:
       - uses: actions-rs/toolchain@v1
@@ -60,7 +60,7 @@ jobs:
   cabal-format-check:
     name: cabal-format-check
     runs-on: ubuntu-latest
-    container: ghcr.io/fossas/haskell-dev-tools:9.0.2
+    container: ghcr.io/fossas/haskell-dev-tools:9.4.7
 
     steps:
       - uses: actions/checkout@v2
@@ -74,14 +74,23 @@ jobs:
     name: cabal-install-check
     runs-on: ubuntu-latest
     # Be sure to update the env var below
-    container: ghcr.io/fossas/haskell-dev-tools:9.0.2
+    container: ghcr.io/fossas/haskell-dev-tools:9.4.7
 
     env:
-      GHC_VERSION: '9.0.2'
+      GHC_VERSION: '9.4.7'
 
     steps:
       - uses: actions/checkout@v3
 
+      # For some reason newer cabal or newer ghc doesn't prioritize cli options like -Wwarn over project file -Werror.
+      # Because -Werror is specified in the project file, we get errors due to missing vendor binaries.
+      # So edit the project file temporarily to not care about warnings.
+      # This is what -Wwarn is supposed to do below.
+      # We don't really lose anything here since it's run with -Werror in other workflows.
+      - name: Delete ghc-options -Werror
+        run: |
+          sed -i '/ghc-options: -Werror/d' cabal.project.ci.linux
+
       # Run `cabal install`.
       - uses: actions/cache@v3
         name: Cache cabal store
@@ -97,8 +106,8 @@ jobs:
         run: |
           apk add xz-dev bzip2-dev bzip2-static
           cabal update
-          # -Wwarn switch because warnings about missing vendor bins would be emitted
-          cabal install --project-file=cabal.project.ci.linux --ghc-options="-Wwarn"
+
+          cabal install --project=cabal.project.ci.linux --ghc-options="-Wwarn"
 
   schema-lint-check:
     name: "schema lint check"

.hlint.yaml

@@ -3,6 +3,13 @@
 - ignore: {name: "Redundant bracket"}
 - ignore: {name: "Use list comprehension"}
 
+# Hlint 3.6.1 has a bug where typed TH splices are not recognized so it reports
+# TemplateHaskell as an unused pragma: https://github.com/ndmitchell/hlint/issues/1531
+# A fix is merged, but has not yet been released.
+# Remove the ignore directive when this commit makes it into a release and is part of haskell-dev-tools.
+# https://github.com/ndmitchell/hlint/commit/505a4d57b972f3ba605ad7a59721cef1f3d98a84
+- ignore: {name: "Unused LANGUAGE pragma", within: [App.Version.TH, App.Version]}
+
 # Import Preferences
 - modules:
   - {name: Data.Set, as: Set, message: "Use complete name for qualified import of Set"}

Makefile

@@ -3,7 +3,7 @@ current_dir := $(dir $(abspath $(lastword $(MAKEFILE_LIST))))
 
 FMT_OPTS := -co -XTypeApplications -o -XImportQualifiedPost
 FIND_OPTS := src test integration-test -type f -name '*.hs'
-GHC_VERSION := 9.0.2
+GHC_VERSION := 9.4.7
 DEV_TOOLS := ghcr.io/fossas/haskell-dev-tools:${GHC_VERSION}
 MOUNTED_DEV_TOOLS_OPTS := --rm
 MOUNTED_DEV_TOOLS_OPTS += --mount "type=bind,source=${current_dir},target=/fossa-cli"

fourmolu.yaml

@@ -2,7 +2,29 @@ indentation: 2
 comma-style: leading # for lists, tuples etc. - can also be 'trailing'
 record-brace-space: false # rec {x = 1} vs. rec{x = 1}
 indent-wheres: true # 'false' means save space by only half-indenting the 'where' keyword
-diff-friendly-import-export: true # 'false' uses Ormolu-style lists
+import-export-style: diff-friendly
 respectful: true # don't be too opinionated about newlines etc.
 haddock-style: single-line # '--' vs. '{-'
 newlines-between-decls: 1 # number of newlines between top-level declarations
+single-constraint-parens: auto
+let-style: inline
+
+# The fixity of operators affects how Fourmolu formats them.
+# Without this directive, we'd get really wonky corrections that would do things like turn this:
+# ```
+# exprA && exprB
+# ```
+# Into
+# ```
+# expr
+#  && exprB
+# ``
+# For operator heavy code, like Aeson parsers, it would be even worse than this.
+# Fourmolu says that it can automatically detect fixities in most cases,
+# but I had to specify these manually to get reasonable formatting.
+# Docs: https://github.com/fourmolu/fourmolu#language-extensions-dependencies-and-fixities
+# If you have issues with operator formatting, usually you can find the right fixity in the haddocks.
+fixities:
+    - infixl 3 <|>
+    - infix 4 ==
+    - infixr 3 &&

spectrometer.cabal

@@ -110,7 +110,7 @@ common deps
     , path                         ^>=0.9.0
     , path-io                      ^>=1.8.0
     , pretty-simple                ^>=4.1.1.0
-    , prettyprinter                >=1.6      && <1.8
+    , prettyprinter                >=1.6       && <1.8
     , prettyprinter-ansi-terminal  ^>=1.1.1
     , random                       ^>=1.2.0
     , raw-strings-qq               ^>=1.1
@@ -124,7 +124,7 @@ common deps
     , template-haskell
     , text                         ^>=2.0.0
     , th-lift-instances            ^>=0.1.17
-    , time                         >=1.9      && <1.13
+    , time                         >=1.9       && <1.13
     , tomland                      ^>=1.3.3.0
     , transformers
     , typed-process                ^>=0.2.6

src/App/Fossa/EmbeddedBinary.hs

@@ -198,7 +198,7 @@ embeddedBinaryThemisIndex :: ByteString
 embeddedBinaryThemisIndex = $(embedFileIfExists "vendor-bins/index.gob.xz")
 
 themisVersion :: Text
-themisVersion = $$themisVersionQ
+themisVersion = $$(themisVersionQ)
 
 embeddedBinaryLernie :: ByteString
 embeddedBinaryLernie = $(embedFileIfExists "vendor-bins/lernie")

src/App/Fossa/VSI/Types.hs

@@ -154,15 +154,15 @@ userDefinedFetcher = "iat"
 isTopLevelProject :: Locator -> Bool
 isTopLevelProject loc = locatorFetcher loc == depTypeToFetcher CustomType
 
--- |A path returned on inferences from sherlock-api.
+-- | A path returned on inferences from sherlock-api.
 --
--- While 'VsiFilePath's look like filepaths, we treat them as text rather than 'FilePath' or 'Path's.
--- Those packages behave based on on the platform they're compiled on, while VSI always uses unix-style paths.
+--  While 'VsiFilePath's look like filepaths, we treat them as text rather than 'FilePath' or 'Path's.
+--  Those packages behave based on on the platform they're compiled on, while VSI always uses unix-style paths.
 newtype VsiFilePath = VsiFilePath {unVsiFilePath :: Text}
   deriving newtype (Eq, Ord, Show, FromJSON, ToJSON)
 
--- |A path for a VSI rule.
--- During processing we change a list of file paths to directory paths for inclusion in rules.
+-- | A path for a VSI rule.
+--  During processing we change a list of file paths to directory paths for inclusion in rules.
 newtype VsiRulePath = VsiRulePath {unVsiRulePath :: Text}
   deriving newtype (Eq, Ord, Show, ToJSON, ToJSONKey, ToString)
 
@@ -220,10 +220,10 @@ generateRules inferenceBody = do
         Nothing -> m
         Just inferenceLocator' -> Map.insertWith (<>) inferenceLocator' (NE.singleton filePath) m
 
--- |Get the shortest prefixes for every filepath in a list.
--- This works by first sorting the list lexicographically and then storing only the initial path that prefixes each group of filepaths.
+-- | Get the shortest prefixes for every filepath in a list.
+--  This works by first sorting the list lexicographically and then storing only the initial path that prefixes each group of filepaths.
 --
--- Ex: ["/foo/bar/baz.c", "/foo/hello.c". "/other/dir/world.c"] -> ["/foo", "/other/dir"]
+--  Ex: ["/foo/bar/baz.c", "/foo/hello.c". "/other/dir/world.c"] -> ["/foo", "/other/dir"]
 getPrefixes :: NE.NonEmpty VsiFilePath -> NE.NonEmpty VsiRulePath
 getPrefixes paths = snd . foldr accumPrefixes startVal $ (NE.tail sorted)
   where

src/Container/OsRelease.hs

@@ -167,8 +167,7 @@ osReleaseParser = do
   properties <- propertiesParser
   let nameId =
         asum
-          ( map (`Map.lookup` properties) ["ID"]
-              ++ [Just "linux"] -- We should default to linux as last resort per spec!
+          ( (`Map.lookup` properties) "ID" : [Just "linux"] -- We should default to linux as last resort per spec!
           )
   let versionId = Map.lookup "VERSION_ID" properties
 

src/Container/TarballReadFs.hs

@@ -288,15 +288,15 @@ runTarballReadFSIO fs tarball = interpret $ \case
   ReadRedactedContentsBS' file -> do
     mapRight Redacted
       <$> readContentBS fs tarball 0 file
-      `catchingIO` FileReadError (toString file)
+        `catchingIO` FileReadError (toString file)
   ReadRedactedContentsBSLimit' file limit -> do
     mapRight Redacted
       <$> readContentsBSLimit fs tarball file limit
-      `catchingIO` FileReadError (toString file)
+        `catchingIO` FileReadError (toString file)
   ReadRedactedContentsText' file -> do
     mapRight Redacted
       <$> readContentText fs tarball file
-      `catchingIO` FileReadError (toString file)
+        `catchingIO` FileReadError (toString file)
   ResolveFile' dir path ->
     resolveFile fs tarball dir path
       `catchingIO` ResolveError (toString dir) (toString path)

src/Control/Carrier/FossaApiClient/Internal/FossaAPIV1.hs

@@ -604,7 +604,7 @@ uploadNativeContainerScan apiOpts ProjectRevision{..} metadata scan = fossaReq $
       resp <- req POST (containerUploadUrl baseUrl) (ReqBodyJson scan) jsonResponse (baseOpts <> opts)
       pure $ responseBody resp
 
--- |Replacement for @Data.HTTP.Req.req@ that additionally logs information about a request in a debug bundle.
+-- | Replacement for @Data.HTTP.Req.req@ that additionally logs information about a request in a debug bundle.
 req ::
   forall method body sig m scheme b.
   ( Req.HttpBodyAllowed (Req.AllowsBody method) (Req.ProvidesBody body)

src/Data/Rpm/DbHeaderBlob.hs

@@ -1,5 +1,5 @@
 -- |
---Description: Functions for reading RPM information out of binary package headers
+-- Description: Functions for reading RPM information out of binary package headers
 module Data.Rpm.DbHeaderBlob (
   PkgInfo (..),
   PkgConversionError (..),

src/Data/Rpm/DbHeaderBlob/Internal.hs

@@ -283,7 +283,7 @@ getV3RegionCount entryMetadatas dataLength dataStart blobData = do
 trd :: (a, b, c) -> c
 trd (_, _, c) = c
 
--- |'runGetOrFail' but don't include parse locations/remaining data in output
+-- | 'runGetOrFail' but don't include parse locations/remaining data in output
 runGetOrFail' :: Get d -> BLS.ByteString -> Either String d
 runGetOrFail' r = bimap trd trd . runGetOrFail r
 

src/Data/String/Conversion.hs

@@ -72,10 +72,10 @@ instance ToText Text.Text where
 instance ToText TL.Text where
   toText = TL.toStrict
 
-instance TypeError ( 'Text "Error: Use encodeUtf8/decodeUtf8 instead") => ToText BS.ByteString where
+instance TypeError ('Text "Error: Use encodeUtf8/decodeUtf8 instead") => ToText BS.ByteString where
   toText = error "unreachable"
 
-instance TypeError ( 'Text "Error: Use encodeUtf8/decodeUtf8 instead") => ToText BL.ByteString where
+instance TypeError ('Text "Error: Use encodeUtf8/decodeUtf8 instead") => ToText BL.ByteString where
   toText = error "unreachable"
 
 instance ToText (Path b t) where
@@ -89,8 +89,8 @@ instance ToText (SomeBase t) where
 instance ToText Key where
   toText = Key.toText
 
--- |Avoid this function in favor of using 'toText' or some other direct conversion if possible.
--- Unfortunately sometimes this is the best way to convert something to text.
+-- | Avoid this function in favor of using 'toText' or some other direct conversion if possible.
+--  Unfortunately sometimes this is the best way to convert something to text.
 showText :: Show a => a -> Text.Text
 showText = toText . show
 
@@ -108,10 +108,10 @@ instance ToLText Text.Text where
 instance ToLText TL.Text where
   toLText = id
 
-instance TypeError ( 'Text "Error: Use encodeUtf8/decodeUtf8 instead") => ToLText BS.ByteString where
+instance TypeError ('Text "Error: Use encodeUtf8/decodeUtf8 instead") => ToLText BS.ByteString where
   toLText = error "unreachable"
 
-instance TypeError ( 'Text "Error: Use encodeUtf8/decodeUtf8 instead") => ToLText BL.ByteString where
+instance TypeError ('Text "Error: Use encodeUtf8/decodeUtf8 instead") => ToLText BL.ByteString where
   toLText = error "unreachable"
 
 instance ToLText (Path b t) where
@@ -128,10 +128,10 @@ instance ToString Text.Text where
 instance ToString TL.Text where
   toString = TL.unpack
 
-instance TypeError ( 'Text "Error: Use decodeUtf8 instead") => ToString BS.ByteString where
+instance TypeError ('Text "Error: Use decodeUtf8 instead") => ToString BS.ByteString where
   toString = error "unreachable"
 
-instance TypeError ( 'Text "Error: Use decodeUtf8 instead") => ToString BL.ByteString where
+instance TypeError ('Text "Error: Use decodeUtf8 instead") => ToString BL.ByteString where
   toString = error "unreachable"
 
 instance ToString (Path b t) where

src/Discovery/Archive.hs

@@ -98,7 +98,7 @@ discover go dir renderAncestry = context "Finding archives" $ do
     traverse_ (\file -> forkTask $ withArchive' file (process file)) files
     pure WalkContinue
 
--- |Given a file extension, return an extraction function for that file type.
+-- | Given a file extension, return an extraction function for that file type.
 selectUnarchiver :: Has (Lift IO) sig m => String -> Maybe (Path Abs Dir -> Path Abs File -> m ())
 selectUnarchiver file
   | ".tar" `isSuffixOf` file = Just extractTar

src/Effect/Grapher.hs

@@ -131,17 +131,17 @@ withLabeling f act = do
   (graph, (labels, _)) <- runGrapher . runState Map.empty $ act
   pure (unlabel f labels graph)
 
--- |This function will run a 'LabeledGrapherC', returning the graph as well as the labels with no post-processing.
+-- | This function will run a 'LabeledGrapherC', returning the graph as well as the labels with no post-processing.
 --
--- Occasionally it isn't possible to transform a graph node and its labels in isolation like 'withLabeling' does.
--- Suppose 'withLabeling' were given a function from =(ty -> Set lbl -> res)= which maps several =ty= to one =res=.
--- There could be multiple =res='s which should be the same, but aren't because each was created from a different =ty= and its associated =res=s.
+--  Occasionally it isn't possible to transform a graph node and its labels in isolation like 'withLabeling' does.
+--  Suppose 'withLabeling' were given a function from =(ty -> Set lbl -> res)= which maps several =ty= to one =res=.
+--  There could be multiple =res='s which should be the same, but aren't because each was created from a different =ty= and its associated =res=s.
 --
--- A concrete example of this is in the GoListPackages tactic.
--- Multiple packages may be associated with production or development envs, but all map to a single module.
--- It is necessary then to collect the labels from multiple packages (=ty=) before producing the final 'Dependency' (=res=).
+--  A concrete example of this is in the GoListPackages tactic.
+--  Multiple packages may be associated with production or development envs, but all map to a single module.
+--  It is necessary then to collect the labels from multiple packages (=ty=) before producing the final 'Dependency' (=res=).
 --
--- Prefer 'withLabeling' if it is enough to examine each =ty= and its set of labels in isolation.
+--  Prefer 'withLabeling' if it is enough to examine each =ty= and its set of labels in isolation.
 runLabeledGrapher :: (Ord ty, Algebra sig m) => LabeledGrapherC ty lbl m a -> m (G.Graphing ty, Labels ty lbl)
 runLabeledGrapher act = do
   (graph, (labels, _)) <- runGrapher . runState Map.empty $ act

src/Effect/ReadFS.hs

@@ -383,15 +383,15 @@ runReadFSIO = interpret $ \case
   ReadRedactedContentsBS' file -> do
     mapRight Redacted
       <$> BS.readFile (toString file)
-      `catchingIO` FileReadError (toString file)
+        `catchingIO` FileReadError (toString file)
   ReadRedactedContentsBSLimit' file limit -> do
     mapRight Redacted
       <$> readContentsBSLimitIO file limit
-      `catchingIO` FileReadError (toString file)
+        `catchingIO` FileReadError (toString file)
   ReadRedactedContentsText' file -> do
     mapRight Redacted
       <$> (decodeUtf8 <$> BS.readFile (toString file))
-      `catchingIO` FileReadError (toString file)
+        `catchingIO` FileReadError (toString file)
   ResolveFile' dir path -> do
     PIO.resolveFile dir (toString path)
       `catchingIO` ResolveError (toString dir) (toString path)

src/Srclib/Types.hs

@@ -48,13 +48,13 @@ instance ToText LicenseScanType where
 instance ToJSON LicenseScanType where
   toJSON = toJSON . toText
 
--- |This type is meant to represent the paths in a project where a particular set of dependencies were discovered.
--- For example, in a project directory that has a @go.mod@ the OriginPath might be 'foo/bar/go.mod'.
--- In a project with VSI dependencies the OriginPath would be the directory the dep was found in, such as 'vendored/zlib/'
+-- | This type is meant to represent the paths in a project where a particular set of dependencies were discovered.
+--  For example, in a project directory that has a @go.mod@ the OriginPath might be 'foo/bar/go.mod'.
+--  In a project with VSI dependencies the OriginPath would be the directory the dep was found in, such as 'vendored/zlib/'
 --
--- OriginPaths were previously `SomeBase File`, however with support for VSI OriginPaths can now be a directory in addition to a file path.
--- The reason we cannot use `SomePath` for this is that outputting an `OriginPath` to JSON in a form like @/foo/bar/path_end@ doesn't say whether the path is a file or directory which is required for parsing to a `SomePath` in `FromJSON`.
--- This type and its exported smart constructors describe that OriginPath is a path, but has no information about whether the path is a file or directory.
+--  OriginPaths were previously `SomeBase File`, however with support for VSI OriginPaths can now be a directory in addition to a file path.
+--  The reason we cannot use `SomePath` for this is that outputting an `OriginPath` to JSON in a form like @/foo/bar/path_end@ doesn't say whether the path is a file or directory which is required for parsing to a `SomePath` in `FromJSON`.
+--  This type and its exported smart constructors describe that OriginPath is a path, but has no information about whether the path is a file or directory.
 newtype OriginPath = OriginPath FilePath
   deriving newtype (Eq, Ord, Show, ToJSON, FromJSON, ToText)
 

src/Strategy/BerkeleyDB/Internal.hs

@@ -49,8 +49,8 @@ readBerkeleyDB file = withBerkeleyBinary $ \bin -> do
 
   -- Handle the JSON response.
   (bdbJsonOutput :: [Text]) <- context "read raw blobs" . execJson' cwd (bdbCommand bin) . decodeUtf8 $ B64.encode fileContent
-  bdbByteOutput <- context "decode base64" . traverse fromEitherShow $ B64.decode <$> fmap encodeUtf8 bdbJsonOutput
-  entries <- context "parse blobs" . traverse fromEitherShow $ readPackageInfo <$> fmap BSL.fromStrict bdbByteOutput
+  bdbByteOutput <- context "decode base64" (traverse (fromEitherShow . B64.decode . encodeUtf8) bdbJsonOutput)
+  entries <- context "parse blobs" (traverse (fromEitherShow . readPackageInfo . BSL.fromStrict) bdbByteOutput)
   context "parse package info" $ traverse parsePkgInfo entries
 
 bdbCommand :: BinaryPaths -> Command

src/Strategy/Bundler.hs

@@ -100,10 +100,8 @@ findLicenses gemspecPath = do
   pure [LicenseResult gemSpecFp (License UnknownType <$> licenses)]
   where
     isLicenseKey Assignment{label = label} =
-      "license"
-        `isSuffixOf` label
-        || "licenses"
-        `isSuffixOf` label
+      "license" `isSuffixOf` label
+        || "licenses" `isSuffixOf` label
     gemSpecFp = toFilePath gemspecPath
 
 mkProject :: BundlerProject -> DiscoveredProject BundlerProject