Fix some hlint warnings - part 2 (#1057)

jhrcek · web-flow · commit af11aceb3421 · 2022-04-15T11:30:46.000-04:00
* Fix some hlint warnings - part 2

* Revert newtype changes
diff --git a/exes/BuildClient.hs b/exes/BuildClient.hs
@@ -396,7 +396,7 @@ getDocumentationStats :: Verbosity
 getDocumentationStats verbosity opts config pkgs = do
     notice verbosity "Downloading documentation index"
     httpSession verbosity "hackage-build" version $ do
-      curGhcVersion <- liftIO $ case (bo_buildOlderGHC opts) of
+      curGhcVersion <- liftIO $ case bo_buildOlderGHC opts of
                                   True -> getGHCversion
                                   False -> return Nothing
       mPackages   <- fmap parseJsonStats <$> requestGET' (packagesUri False curGhcVersion)
diff --git a/src/Distribution/Client.hs b/src/Distribution/Client.hs
@@ -140,8 +140,7 @@ downloadOldIndex uri cacheDir = do
     logFile   = cacheDir </> "log"
 
     mergeLogInfo pkgids theLog =
-        catMaybes
-      . map selectDetails
+        mapMaybe selectDetails
       $ mergeBy (\pkgid entry -> compare pkgid (entryPkgId entry))
                 (sort pkgids)
                 ( map (maximumBy (comparing entryTime))
diff --git a/src/Distribution/Client/ParseApacheLogs.hs b/src/Distribution/Client/ParseApacheLogs.hs
@@ -26,8 +26,7 @@ logToDownloadCounts =
   . map formatOutput
   . Map.toList
   . accumHist
-  . catMaybes
-  . map ((packageGET >=> parseGET) . parseLine . SBS.concat . LBS.toChunks)
+  . mapMaybe ((packageGET >=> parseGET) . parseLine . SBS.concat . LBS.toChunks)
   . LBS.lines
 
 data LogLine = LogLine {
diff --git a/src/Distribution/Server/Features/AdminFrontend.hs b/src/Distribution/Server/Features/AdminFrontend.hs
@@ -1,6 +1,5 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
-{-# LANGUAGE NamedFieldPuns, RecordWildCards, BangPatterns,
-             StandaloneDeriving, GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE NamedFieldPuns, RecordWildCards #-}
 module Distribution.Server.Features.AdminFrontend (
     initAdminFrontendFeature
   ) where
diff --git a/src/Distribution/Server/Features/BuildReports/BuildReport.hs b/src/Distribution/Server/Features/BuildReports/BuildReport.hs
@@ -89,7 +89,6 @@ import Text.StringTemplate ()
 import Text.StringTemplate.Classes
          ( SElem(..), ToSElem(..) )
 
-import Data.String (fromString)
 import Data.Aeson
 import Data.Functor.Identity (Identity)
 import Data.List
@@ -607,10 +606,10 @@ data BuildFiles = BuildFiles {
 instance Data.Aeson.FromJSON BuildFiles where
   parseJSON = withObject "buildFiles" $ \o ->
     BuildFiles
-      <$> o .:? fromString "report"
-      <*> o .:? fromString "log"
-      <*> o .:? fromString "coverage"
-      <*> o .: fromString "buildFail"
+      <$> o .:? "report"
+      <*> o .:? "log"
+      <*> o .:? "coverage"
+      <*> o .: "buildFail"
 
 instance Data.Aeson.ToJSON BuildFiles where
   toJSON p = object [
@@ -631,21 +630,21 @@ instance Data.Aeson.ToJSON PkgDetails where
   toJSON p = object [
     "pkgid"      .= (DT.display $ pkid p::String),
     "docs"       .= docs p,
-    "failCnt"    .= failCnt  p,
-    "buildTime"  .= buildTime  p,
-    "ghcId"     .= (k $ ghcId p) ]
+    "failCnt"    .= failCnt p,
+    "buildTime"  .= buildTime p,
+    "ghcId"      .= k (ghcId p) ]
     where
       k (Just a) = Just $ DT.display a
       k Nothing = Nothing
 
 instance Data.Aeson.FromJSON PkgDetails where
   parseJSON = withObject "pkgDetails" $ \o ->
     PkgDetails
-      <$> ((\k -> maybe (fail $ "failed to parse "<>k) pure $ P.simpleParsec k) =<< (o .: (fromString "pkgid")))
-      <*> o .: fromString "docs"
-      <*> o .:? fromString "failCnt"
-      <*> o .:? fromString "buildTime"
-      <*> fmap parseVersion (o .:? (fromString "ghcId"))
+      <$> ((\k -> maybe (fail $ "failed to parse "<>k) pure $ P.simpleParsec k) =<< (o .: "pkgid"))
+      <*> o .: "docs"
+      <*> o .:? "failCnt"
+      <*> o .:? "buildTime"
+      <*> fmap parseVersion (o .:? "ghcId")
     where
       parseVersion :: Maybe String -> Maybe Version
       parseVersion Nothing = Nothing
diff --git a/src/Distribution/Server/Features/BuildReports/Render.hs b/src/Distribution/Server/Features/BuildReports/Render.hs
@@ -7,7 +7,6 @@ module Distribution.Server.Features.BuildReports.Render
 import Distribution.Server.Framework
 
 import Distribution.Server.Features.BuildReports
-import Distribution.Server.Features.BuildReports.BuildReports (BuildReportId)
 import Distribution.Server.Features.BuildReports.BuildReport (BuildReport(..), InstallOutcome(..), Outcome(..))
 import Distribution.Server.Features.Documentation
 
diff --git a/src/Distribution/Server/Features/EditCabalFiles.hs b/src/Distribution/Server/Features/EditCabalFiles.hs
@@ -1,5 +1,5 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
-{-# LANGUAGE NamedFieldPuns, RecordWildCards, BangPatterns #-}
+{-# LANGUAGE NamedFieldPuns, RecordWildCards #-}
 module Distribution.Server.Features.EditCabalFiles (
     initEditCabalFilesFeature
 
diff --git a/src/Distribution/Server/Features/HoogleData.hs b/src/Distribution/Server/Features/HoogleData.hs
@@ -1,6 +1,4 @@
-{-# LANGUAGE DeriveDataTypeable, TypeFamilies, TemplateHaskell,
-             RankNTypes, NamedFieldPuns, RecordWildCards,
-             RecursiveDo, BangPatterns, CPP #-}
+{-# LANGUAGE TypeFamilies, RankNTypes, NamedFieldPuns, RecordWildCards, CPP #-}
 module Distribution.Server.Features.HoogleData (
     initHoogleDataFeature,
     HoogleDataFeature(..),
diff --git a/src/Distribution/Server/Features/Html/HtmlUtilities.hs b/src/Distribution/Server/Features/Html/HtmlUtilities.hs
@@ -85,8 +85,8 @@ htmlUtilities CoreFeature{coreResource}
             addns = toStr $ fst revTags
             delns = toStr $ snd revTags
             disp = thediv ! [theclass "box"] << [ paragraph << [bold $ toHtml "Current Tags: ", toHtml tagsStr, br]
-                                                , paragraph << [bold $ toHtml "Additions to be reviewed: ", toHtml $ if (addns /= "") then addns else "None", br]
-                                                , paragraph << [bold $ toHtml "Deletions to be reviewed: ", toHtml $ if (delns /= "") then delns else "None", br]
+                                                , paragraph << [bold $ toHtml "Additions to be reviewed: ", toHtml $ if addns /= "" then addns else "None", br]
+                                                , paragraph << [bold $ toHtml "Deletions to be reviewed: ", toHtml $ if delns /= "" then delns else "None", br]
                                                 ]
         in
             [ big $ bold $ toHtml $ display pkgname
diff --git a/src/Distribution/Server/Features/PackageCandidates.hs b/src/Distribution/Server/Features/PackageCandidates.hs
@@ -494,7 +494,7 @@ candidatesFeature ServerEnv{serverBlobStore = store}
           PackageIndex.Unambiguous [] -> return Nothing -- can this ever occur?
 
           PackageIndex.Ambiguous mps -> do
-            let matchingPackages = concat . map (take 1) $ mps
+            let matchingPackages = concatMap (take 1) mps
             groups <- mapM (liftIO . Group.queryUserGroup . maintainersGroup . packageName) matchingPackages
             if not . any (uid `Group.member`) $ groups
               then return $ Just $ ErrorResponse 403 [] "Publish failed" (caseClash matchingPackages)
diff --git a/src/Distribution/Server/Features/PreferredVersions/State.hs b/src/Distribution/Server/Features/PreferredVersions/State.hs
@@ -9,7 +9,7 @@ import Distribution.Package
 import Distribution.Version
 
 import Data.Acid  (Query, Update, makeAcidic)
-import Data.Maybe (isJust, fromMaybe)
+import Data.Maybe (fromMaybe, isNothing)
 import Data.Typeable (Typeable)
 import Control.Arrow (second)
 import Control.Monad (ap)
@@ -46,18 +46,17 @@ consolidateRanges ranges depr =
 data VersionStatus = NormalVersion | DeprecatedVersion | UnpreferredVersion deriving (Show, Typeable, Eq, Ord, Enum)
 
 getVersionStatus :: PreferredInfo -> Version -> VersionStatus
-getVersionStatus info version = case version `elem` deprecatedVersions info of
-    True  -> DeprecatedVersion
-    False -> case maybe True (withinRange version) (sumRange info) of
-        True  -> NormalVersion
-        False -> UnpreferredVersion
+getVersionStatus info version
+    | version `elem` deprecatedVersions info = DeprecatedVersion
+    | maybe True (withinRange version) (sumRange info) = NormalVersion
+    | otherwise = UnpreferredVersion
 
 classifyVersions :: PreferredInfo -> [Version] -> [(Version, VersionStatus)]
 classifyVersions (PreferredInfo [] [] _) = map (flip (,) NormalVersion)
 classifyVersions info = map ((,) `ap` getVersionStatus info)
 
 partitionVersions :: PreferredInfo -> [Version] -> ([Version], [Version], [Version])
-partitionVersions info versions = if (not . isJust $ sumRange info) then (versions, [], []) else go versions
+partitionVersions info versions = if isNothing $ sumRange info then (versions, [], []) else go versions
   where go :: [Version] -> ([Version], [Version], [Version]) -- foldr-type approach
         go (v:vs) = let ~(norm, depr, unpref) = go vs in case getVersionStatus info v of
             NormalVersion -> (v:norm, depr, unpref)
diff --git a/src/Distribution/Server/Features/Search/BM25F.hs b/src/Distribution/Server/Features/Search/BM25F.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE RecordWildCards #-}
-
 -- | See:
 --
 -- * \"The Probabilistic Relevance Framework: BM25 and Beyond\"
diff --git a/src/Distribution/Server/Features/Search/DocFeatVals.hs b/src/Distribution/Server/Features/Search/DocFeatVals.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE BangPatterns, GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 module Distribution.Server.Features.Search.DocFeatVals (
     DocFeatVals,
     featureValue,
diff --git a/src/Distribution/Server/Features/Search/ExtractDescriptionTerms.hs b/src/Distribution/Server/Features/Search/ExtractDescriptionTerms.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE BangPatterns, NamedFieldPuns, GeneralizedNewtypeDeriving #-}
-
 module Distribution.Server.Features.Search.ExtractDescriptionTerms (
     extractSynopsisTerms,
     extractDescriptionTerms,
@@ -50,7 +48,7 @@ splitTok tok =
         ([],      _:trailing) -> go trailing
         (leading, _:trailing) -> leading : go trailing
         ([],      [])         -> []
-        (leading, [])         -> leading : []
+        (leading, [])         -> [leading]
 
 
 extractDescriptionTerms :: [Text] -> Set Text -> String -> [Text]
diff --git a/src/Distribution/Server/Features/Security.hs b/src/Distribution/Server/Features/Security.hs
@@ -1,5 +1,4 @@
 {-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE NamedFieldPuns  #-}
 {-# LANGUAGE BangPatterns    #-}
 
 -- | TUF security features
diff --git a/src/Distribution/Server/Features/ServerIntrospect.hs b/src/Distribution/Server/Features/ServerIntrospect.hs
@@ -140,7 +140,7 @@ apiDocPageHtml serverFeatures = hackagePage title content
         renderComponents (StaticBranch sdir:cs) =
           let (rest, url) = renderComponents cs
           in ("/" +++ sdir +++ rest, liftM (("/" ++ sdir) ++) url)
-        renderComponents (DynamicBranch leaf:[])
+        renderComponents [DynamicBranch leaf]
           | ResourceFormat _ (Just (StaticBranch _)) <- resourceFormat resource =
               ("/" +++ leaf, Just ("/" ++ leaf))
         renderComponents (DynamicBranch ddir:cs) =
@@ -228,7 +228,7 @@ apiDocJSON serverFeatures = featureList
 
         renderComponents (StaticBranch  sdir:cs) = "/" ++ sdir
                                                        ++ renderComponents cs
-        renderComponents (DynamicBranch leaf:[])
+        renderComponents [DynamicBranch leaf]
           | ResourceFormat _ (Just (StaticBranch _)) <- resourceFormat resource
                                                  = "/" ++ leaf
         renderComponents (DynamicBranch ddir:cs) = "/" ++ ":" ++ ddir
diff --git a/src/Distribution/Server/Features/StaticFiles.hs b/src/Distribution/Server/Features/StaticFiles.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE NamedFieldPuns, RecordWildCards, BangPatterns #-}
+{-# LANGUAGE NamedFieldPuns #-}
 module Distribution.Server.Features.StaticFiles (
     initStaticFilesFeature
   ) where
diff --git a/src/Distribution/Server/Features/Tags.hs b/src/Distribution/Server/Features/Tags.hs
@@ -288,7 +288,6 @@ tagsFeature CoreFeature{ queryGetPackageIndex }
                                     let addTags = Set.fromList aliases `Set.difference` calcTags
                                         delTags = Set.fromList del `Set.intersection` calcTags
                                     void $ updateState tagsState $ InsertReviewTags pkgname addTags delTags
-                                    return ()
                                 else errBadRequest "Authorization Error" [MText "You need to be logged in to propose tags"]
                     _ -> errBadRequest "Tags not recognized" [MText "Couldn't parse your tag list. It should be comma separated with any number of alphanumerical tags. Tags can also also have -+#*."]
           Nothing -> errBadRequest "Tags not recognized" [MText "Couldn't parse your tag list. It should be comma separated with any number of alphanumerical tags. Tags can also also have -+#*."]
diff --git a/src/Distribution/Server/Features/Upload.hs b/src/Distribution/Server/Features/Upload.hs
@@ -352,7 +352,7 @@ uploadFeature ServerEnv{serverBlobStore = store}
                          else return Nothing
 
                 (False,PackageIndex.Ambiguous mps) -> do
-                      let matchingPackages = concat . map (take 1) $ mps
+                      let matchingPackages = concatMap (take 1) mps
                       groups <- mapM (queryUserGroup . maintainersGroup . packageName) matchingPackages
                       if not . any (uid `Group.member`) $ groups
                          then uploadError (caseClash matchingPackages)
diff --git a/src/Distribution/Server/Features/UserSignup.hs b/src/Distribution/Server/Features/UserSignup.hs
@@ -361,16 +361,14 @@ userSignupFeature ServerEnv{serverBaseURI, serverCron}
 
     querySignupInfo :: Nonce -> MonadIO m => m (Maybe SignupResetInfo)
     querySignupInfo nonce =
-            queryState signupResetState (LookupSignupResetInfo nonce)
-        >>= return . justSignupInfo
+        justSignupInfo <$> queryState signupResetState (LookupSignupResetInfo nonce)
       where
         justSignupInfo (Just info@SignupInfo{}) = Just info
         justSignupInfo _                        = Nothing
 
     queryResetInfo :: Nonce -> MonadIO m => m (Maybe SignupResetInfo)
     queryResetInfo nonce =
-            queryState signupResetState (LookupSignupResetInfo nonce)
-        >>= return . justResetInfo
+        justResetInfo <$> queryState signupResetState (LookupSignupResetInfo nonce)
       where
         justResetInfo (Just info@ResetInfo{}) = Just info
         justResetInfo _                       = Nothing
diff --git a/src/Distribution/Server/Framework/BlobStorage.hs b/src/Distribution/Server/Framework/BlobStorage.hs
@@ -82,7 +82,7 @@ blobETag :: BlobId -> ETag
 blobETag = ETag . blobMd5
 
 readBlobId :: String -> Either String BlobId
-readBlobId = either Left (Right . BlobId) . readDigest
+readBlobId = fmap BlobId . readDigest
 
 instance SafeCopy BlobId where
   version = 2
diff --git a/src/Distribution/Server/Framework/HtmlFormWrapper.hs b/src/Distribution/Server/Framework/HtmlFormWrapper.hs
@@ -149,7 +149,7 @@ requestFormDataAsJSON = do
     let keyvals = [ (k, v)
                   | (k, Input { inputValue = Right v }) <- fromMaybe [] mbody
                   , case k of '_':_ -> False; _ -> True ]
-        paths   = [ (parsePathTmpl (BS8.unpack v) k)
+        paths   = [ parsePathTmpl (BS8.unpack v) k
                   | (k, v) <- keyvals ]
     case accumJPaths paths of
       Nothing -> return $ Left (zip keyvals paths )
diff --git a/src/Distribution/Server/Packages/Types.hs b/src/Distribution/Server/Packages/Types.hs
@@ -303,7 +303,7 @@ instance Migrate PkgInfo_v1 where
     migrate (PkgInfo_v0 a b c d e) =
       PkgInfo_v1 (migrate a) b
                  [ (migrate (migrate pt), migrateUploadInfo ui) | (pt, ui) <- c ]
-                 [ (cf, (migrateUploadInfo ui)) | (cf, ui) <- d ]
+                 [ (cf, migrateUploadInfo ui) | (cf, ui) <- d ]
                  (migrateUploadInfo e)
       where
         migrateUploadInfo (UTCTime_v0 ts, UserId_v0 uid) = (ts, UserId uid)
diff --git a/src/Distribution/Server/Packages/Unpack.hs b/src/Distribution/Server/Packages/Unpack.hs
@@ -452,7 +452,7 @@ explainTarError (FutureTimeError entryname time serverTime) =
  ++ "with cabal-install-1.18.0.2 or older have this problem)."
 explainTarError (PermissionsError entryname mode) =
     "The tarball entry " ++ quote entryname ++ " has file permissions that are "
- ++ "broken: " ++ (showMode mode) ++ ". Permissions must be 644 at a minimum "
+ ++ "broken: " ++ showMode mode ++ ". Permissions must be 644 at a minimum "
  ++ "for files and 755 for directories."
   where
     showMode :: Tar.Permissions -> String
diff --git a/src/Distribution/Server/Pages/Package.hs b/src/Distribution/Server/Pages/Package.hs
@@ -236,7 +236,7 @@ renderDetailedDependencies pkgRender =
     list :: [Html] -> Html
     list items = thediv ! [identifier "detailed-dependencies"] << unordList items
 
-    renderComponent :: (CondBranch ConfVar [Dependency] IsBuildable)
+    renderComponent :: CondBranch ConfVar [Dependency] IsBuildable
                     -> Maybe Html
     renderComponent (CondBranch condition then' else')
         | Just thenHtml <- render then' =
diff --git a/src/Distribution/Server/Pages/PackageFromTemplate.hs b/src/Distribution/Server/Pages/PackageFromTemplate.hs
@@ -111,8 +111,8 @@ packagePageTemplate render
     , "executables"       $= (commaList . map toHtml $ rendExecNames render)
     , "downloadSection"   $= Old.downloadSection render
     , "stability"         $= renderStability desc
-    , "isDeprecated"      $= (if deprs == Nothing then False else True)
-    , "deprecatedMsg"     $= (deprHtml deprs)
+    , "isDeprecated"      $= isJust deprs
+    , "deprecatedMsg"     $= deprHtml deprs
     ]
   where
     -- Access via "$hackage.varName$"
diff --git a/src/Distribution/Server/Pages/Recent.hs b/src/Distribution/Server/Pages/Recent.hs
@@ -145,7 +145,7 @@ recentRevisionsFeed users hostURI now pkgs = RSS
     desc = "The 40 most recent revisions to cabal metadata in Hackage (or last 48 hours worth, whichever is greater), the Haskell package database."
     twoDaysAgo = addUTCTime (negate $ 60 * 60 * 48) now
     pkgListTwoDays = takeWhile (\p -> pkgLatestUploadTime p > twoDaysAgo) pkgs
-    pkgList = if (length pkgListTwoDays > 40) then pkgListTwoDays else take 40 pkgs
+    pkgList = if length pkgListTwoDays > 40 then pkgListTwoDays else take 40 pkgs
     updated = maybe now (fst . pkgOriginalUploadInfo) (listToMaybe pkgList)
 
 channel :: UTCTime -> [RSS.ChannelElem]
diff --git a/src/Distribution/Server/Util/CabalRevisions.hs b/src/Distribution/Server/Util/CabalRevisions.hs
@@ -690,7 +690,6 @@ changesOkSet what render old new = do
         logChange (Change Normal ("removed " ++ what) (renderSet removed) "")
     unless (Set.null added) $
         logChange (Change Normal ("added " ++ what) "" (renderSet added))
-    return ()
   where
     added   = new Set.\\ old
     removed = old Set.\\ new
diff --git a/src/Distribution/Server/Util/Markdown.hs b/src/Distribution/Server/Util/Markdown.hs
@@ -47,7 +47,7 @@ instance ToPlainText (HHtml a) where
   toPlainText (HHtml x) = toPlainText x
 
 instance Rangeable (Html a) => Rangeable (HHtml a) where
-  ranged sr (HHtml x) = (HHtml $ ranged sr x)
+  ranged sr (HHtml x) = HHtml $ ranged sr x
 
 instance (Rangeable (Html a), Rangeable (HHtml a)) => IsInline (HHtml a) where
   lineBreak = HHtml lineBreak
diff --git a/src/Distribution/Server/Util/ServeTarball.hs b/src/Distribution/Server/Util/ServeTarball.hs
@@ -129,9 +129,9 @@ loadTarEntry tarfile off = do
 serveTarEntry :: FilePath -> TarIndex.TarEntryOffset -> FilePath -> IO Response
 serveTarEntry tarfile off fname = do
     Right (size, body) <- loadTarEntry tarfile off
-    return . ((setHeader "Content-Length" (show size)) .
-              (setHeader "Content-Type" mimeType)) $
-              resultBS 200 body
+    return . setHeader "Content-Length" (show size)
+           . setHeader "Content-Type" mimeType
+           $ resultBS 200 body
   where mimeType = mime fname
 
 constructTarIndexFromFile :: FilePath -> IO TarIndex
diff --git a/tests/Distribution/Server/Packages/UnpackTest.hs b/tests/Distribution/Server/Packages/UnpackTest.hs
@@ -22,7 +22,7 @@ testPermissions :: FilePath                              -- ^ .tar.gz file to te
                 -> (Tar.Entry -> Maybe CombinedTarErrs)  -- ^ Converter to create errors if necessary
                 -> Assertion
 testPermissions tarPath mangler = do
-    entries <- return . Tar.read . GZip.decompress =<< BL.readFile tarPath
+    entries <- Tar.read . GZip.decompress <$> BL.readFile tarPath
     let mappedEntries = Tar.foldEntries Tar.Next Tar.Done (Tar.Fail . FormatError) entries
     when (checkEntries mangler mappedEntries /= checkUselessPermissions mappedEntries) $
         assertFailure ("Permissions check did not match expected for: " ++ tarPath)
diff --git a/tests/HttpUtils.hs b/tests/HttpUtils.hs
@@ -136,7 +136,7 @@ execPostFile expectedCode auth req field (filename, fileContents) =
     req'     = setRequestBody req
                               ("multipart/form-data; boundary=" ++ boundary,
                                body)
-    unlines' = concat . map (++ "\r\n")
+    unlines' = concatMap (++ "\r\n")
     body     = unlines' [
         "--" ++ boundary
       , "Content-Disposition: form-data; name=" ++ show field ++ "; filename=" ++ show filename
