diff --git a/exes/BuildClient.hs b/exes/BuildClient.hs index d16bdad7f..da90a8fbf 100644 --- a/exes/BuildClient.hs +++ b/exes/BuildClient.hs @@ -109,7 +109,7 @@ main = topHandler $ do " hackage-build build [packages] [options]", " hackage-build stats", "Options:"] - mapM_ putStrLn $ strs + mapM_ putStrLn strs putStrLn $ usageInfo usageHeader buildFlagDescrs unless (null strs) exitFailure Init uri auxUris -> initialise opts uri auxUris @@ -339,18 +339,18 @@ infoStats verbosity mDetailedStats pkgIdsHaveDocs = do -- NOTE: Expects the same number of columns in every row! printTable :: [[String]] -> String printTable xss = intercalate "\n" - . map (intercalate " ") + . map unwords . map padCols $ xss where colWidths :: [[Int]] - colWidths = map (map length) $ xss + colWidths = map (map length) xss maxColWidths :: [Int] - maxColWidths = foldr1 (\xs ys -> map (uncurry max) (zip xs ys)) colWidths + maxColWidths = map maximum (transpose colWidths) padCols :: [String] -> [String] - padCols cols = map (uncurry padTo) (zip maxColWidths cols) + padCols cols = zipWith padTo maxColWidths cols padTo :: Int -> String -> String padTo len str = str ++ replicate (len - length str) ' ' @@ -401,7 +401,7 @@ getDocumentationStats verbosity opts config pkgs = do False -> return Nothing mPackages <- fmap parseJsonStats <$> requestGET' (packagesUri False curGhcVersion) mCandidates <- fmap parseJsonStats <$> requestGET' (packagesUri True curGhcVersion) - liftIO $ putStrLn $ show curGhcVersion + liftIO $ print curGhcVersion case (mPackages, mCandidates) of -- Download failure (Nothing, _) -> fail $ "Could not download " ++ show (packagesUri False curGhcVersion) @@ -426,9 +426,9 @@ getDocumentationStats verbosity opts config pkgs = do hClose moutput handler <- openFile dirloc ReadWriteMode contents <- hGetContents handler - let res = read contents :: [(String, String)] - version' = fmap (\(_,b) -> b) $ find (\(a,_)-> a=="Project version") res - return $ version' + let res = read contents :: [(String, String)] + version' = lookup "Project version" res + return version' getQry :: [PackageIdentifier] -> String getQry [] = "" @@ -576,7 +576,7 @@ processPkg verbosity opts config docInfo = do coverageFile <- mapM (coveragePackage verbosity opts docInfo) hpcLoc -- Modify test-outcome and rewrite report file. - mapM (setTestStatus mRpt buildReport) testOutcome + mapM_ (setTestStatus mRpt buildReport) testOutcome case bo_dryRun opts of True -> return () @@ -610,7 +610,7 @@ processPkg verbosity opts config docInfo = do let buildReport' = fmap (unlines.setTestOutcome testOutcome) $ fmap lines buildReport rewriteRpt mRpt buildReport' -coveragePackage :: Verbosity -> BuildOpts -> DocInfo -> FilePath -> IO (FilePath) +coveragePackage :: Verbosity -> BuildOpts -> DocInfo -> FilePath -> IO FilePath coveragePackage verbosity opts docInfo loc = do let pkgid = docInfoPackage docInfo dir = takeDirectory loc @@ -886,7 +886,7 @@ putBuildFiles config docInfo reportFile buildLogFile coverageFile installOk = do (_, response) <- request Request { rqURI = uri, rqMethod = PUT, - rqHeaders = [Header HdrContentType ("application/json"), + rqHeaders = [Header HdrContentType "application/json", Header HdrContentLength (show (BS.length body))], rqBody = body } diff --git a/exes/ImportClient.hs b/exes/ImportClient.hs index ebe4d3af7..b1c4a1295 100644 --- a/exes/ImportClient.hs +++ b/exes/ImportClient.hs @@ -119,7 +119,7 @@ main = topHandler $ do printHelp help = getProgName >>= putStr . help printOptionsList = putStr . unlines printErrors errs = do - putStr (concat (intersperse "\n" errs)) + putStr (intercalate "\n" errs) exitWith (ExitFailure 1) printVersion = putStrLn $ "hackage-import " ++ display Paths.version @@ -408,7 +408,7 @@ importIndex jobs indexFile baseURI = do =<< LBS.readFile indexFile pkgs' <- evaluate (sortBy (comparing fst) pkgs) - info $ "Uploading..." + info "Uploading..." concForM_ jobs pkgs' $ \tasks -> httpSession $ do @@ -802,7 +802,7 @@ downloadCountCommand = where name = "downloads" shortDesc = "Import download counts" - longDesc = Just $ \_ -> unlines $ [ + longDesc = Just $ \_ -> unlines [ "Replace the on-disk download statistics with the download statistics" , "extracted from Apache log files (in .gz format)" ] diff --git a/exes/Main.hs b/exes/Main.hs index 30322ce3f..466960116 100644 --- a/exes/Main.hs +++ b/exes/Main.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE PatternGuards #-} - module Main where import qualified Distribution.Server as Server @@ -44,8 +42,8 @@ import Data.Maybe ( isNothing ) import Data.List ( intercalate, isInfixOf ) -import Data.Traversable - ( forM ) +import Data.Foldable + ( forM_ ) import Data.Version ( showVersion ) import Control.Monad @@ -377,7 +375,7 @@ runAction opts = do fail $ "Sorry, the server assumes it will be served (or proxied) " ++ " via http or https, so cannot use uri scheme " ++ uriScheme uri | isNothing (uriAuthority uri) -> - fail $ "The base-uri has to include the full host name" + fail "The base-uri has to include the full host name" | uriPath uri `notElem` ["", "/"] -> fail $ "Sorry, the server assumes the base-uri to be at the root of " ++ " the domain, so cannot use " ++ uriPath uri @@ -689,7 +687,7 @@ testBackupCommand = flagTestBackupScrubbed (\v flags -> flags { flagTestBackupScrubbed = v }) (noArg (Flag True)) , option [] ["features"] - ("Only test the specified features") + "Only test the specified features" flagTestBackupFeatures (\v flags -> flags { flagTestBackupFeatures = v }) (reqArgFlag "FEATURES") ] @@ -920,7 +918,7 @@ withServer config doTemp = bracket initialise shutdown loginfo verbosity "Initializing happstack-state..." server <- Server.initialise config loginfo verbosity "Server data loaded into memory" - void $ forM mtemp $ \temp -> do + forM_ mtemp $ \temp -> do loginfo verbosity "Tearing down temp server" Server.tearDownTemp temp return server diff --git a/exes/MirrorClient.hs b/exes/MirrorClient.hs index dcc0c1012..5cf0cc548 100644 --- a/exes/MirrorClient.hs +++ b/exes/MirrorClient.hs @@ -126,7 +126,7 @@ mirrorOnce verbosity opts ignoreCount = length pkgsToMirror - mirrorCount if mirrorCount == 0 - then liftIO $ notice verbosity $ "No packages to mirror" + then liftIO $ notice verbosity "No packages to mirror" else do liftIO $ notice verbosity $ show mirrorCount ++ " packages to mirror." diff --git a/src/Distribution/Client.hs b/src/Distribution/Client.hs index a22fb1224..27a2e6416 100644 --- a/src/Distribution/Client.hs +++ b/src/Distribution/Client.hs @@ -100,7 +100,7 @@ data PkgIndexInfo = PkgIndexInfo downloadIndex :: URI -> FilePath -> HttpSession [PkgIndexInfo] downloadIndex uri | isOldHackageURI uri = downloadOldIndex uri | otherwise = downloadNewIndex uri - where + isOldHackageURI :: URI -> Bool isOldHackageURI uri diff --git a/src/Distribution/Client/Mirror/Repo/Secure.hs b/src/Distribution/Client/Mirror/Repo/Secure.hs index b0b2ae361..670d5aa12 100644 --- a/src/Distribution/Client/Mirror/Repo/Secure.hs +++ b/src/Distribution/Client/Mirror/Repo/Secure.hs @@ -187,12 +187,12 @@ finalizeLocalMirror' cache repoRoot = (`runContT` return) $ do let (dir, template) = splitFileName dst bracket (openBinaryTempFileWithDefaultPermissions dir template) (\(temp, h) -> ignoreIOErrors (hClose h >> removeFile temp)) $ - (\(temp, h) -> do + \(temp, h) -> do BS.L.hPut h =<< BS.L.readFile src hClose h a <- callback () renameFile temp dst - return a) + return a ignoreIOErrors :: IO () -> IO () ignoreIOErrors = handle $ \(_ :: IOException) -> return () diff --git a/src/Distribution/Client/Mirror/State.hs b/src/Distribution/Client/Mirror/State.hs index f3fb6a42e..4184be4e9 100644 --- a/src/Distribution/Client/Mirror/State.hs +++ b/src/Distribution/Client/Mirror/State.hs @@ -11,7 +11,7 @@ module Distribution.Client.Mirror.State ( -- stdlib import Control.Exception import Control.Monad -import Data.Maybe (catMaybes) +import Data.Maybe (mapMaybe) import Data.Set (Set) import Network.URI import System.Directory @@ -115,7 +115,7 @@ readPkgProblemFile file = do exists <- doesFileExist file if exists then evaluate . Set.fromList - . catMaybes . map simpleParse . lines + . mapMaybe simpleParse . lines =<< readFile file else return Set.empty diff --git a/src/Distribution/Server.hs b/src/Distribution/Server.hs index 7d3d31280..54da9a5a7 100644 --- a/src/Distribution/Server.hs +++ b/src/Distribution/Server.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE NamedFieldPuns, RecordWildCards #-} +{-# LANGUAGE NamedFieldPuns #-} module Distribution.Server ( -- * Server control Server(..), @@ -287,7 +287,7 @@ initState server (admin, pass) = do Nothing -> fail "Couldn't parse admin name (should be alphanumeric)" case muid of Right uid -> Group.addUserToGroup adminGroup uid - Left Users.ErrUserNameClash -> fail $ "Inconceivable!! failed to create admin user" + Left Users.ErrUserNameClash -> fail "Inconceivable!! failed to create admin user" -- The top-level server part. -- It collects resources from Distribution.Server.Features, collects @@ -341,7 +341,7 @@ setUpTemp sconf secs = do -- cost to it threadDelay $ secs*1000000 -- could likewise specify a mirror to redirect to for tarballs, and 503 for everything else - runServer listenOn $ (resp 503 $ setHeader "Content-Type" "text/html" $ toResponse html503) + runServer listenOn $ resp 503 $ setHeader "Content-Type" "text/html" $ toResponse html503 return (TempServer tid) where listenOn = confListenOn sconf @@ -362,4 +362,4 @@ tearDownTemp :: TempServer -> IO () tearDownTemp (TempServer tid) = do killThread tid -- give the server enough time to release the bind - threadDelay $ 1000000 + threadDelay 1000000 diff --git a/src/Distribution/Server/Features/AdminLog.hs b/src/Distribution/Server/Features/AdminLog.hs index 9081c50c5..e32ac14eb 100755 --- a/src/Distribution/Server/Features/AdminLog.hs +++ b/src/Distribution/Server/Features/AdminLog.hs @@ -14,7 +14,7 @@ import Distribution.Server.Features.Users import Data.SafeCopy (base, deriveSafeCopy) import Data.Typeable -import Data.Maybe(catMaybes) +import Data.Maybe(mapMaybe) import Control.Monad.Reader import qualified Control.Monad.State as State import Data.Time (UTCTime) @@ -161,7 +161,7 @@ restoreAdminLogBackup = importLogs :: AdminLog -> BS.ByteString -> AdminLog importLogs (AdminLog ls) = - AdminLog . (++ls) . catMaybes . map fromRecord . lines . unpackUTF8 + AdminLog . (++ls) . mapMaybe fromRecord . lines . unpackUTF8 where fromRecord :: String -> Maybe (UTCTime,UserId,AdminAction,BS.ByteString) fromRecord = readMaybe diff --git a/src/Distribution/Server/Features/Browse.hs b/src/Distribution/Server/Features/Browse.hs index c2cb4549f..4e3c52a02 100644 --- a/src/Distribution/Server/Features/Browse.hs +++ b/src/Distribution/Server/Features/Browse.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE BlockArguments, NamedFieldPuns, TupleSections #-} +{-# LANGUAGE BlockArguments, NamedFieldPuns #-} module Distribution.Server.Features.Browse (initBrowseFeature, PaginationConfig(..), StartIndex(..), NumElems(..), paginate) where import Control.Arrow (left) diff --git a/src/Distribution/Server/Features/Browse/ApplyFilter.hs b/src/Distribution/Server/Features/Browse/ApplyFilter.hs index 3f2b9421d..930b150ce 100644 --- a/src/Distribution/Server/Features/Browse/ApplyFilter.hs +++ b/src/Distribution/Server/Features/Browse/ApplyFilter.hs @@ -28,8 +28,7 @@ applyFilter now isSearch coreResource userResource tagsResource DistroFeature{qu packages <- filterM filterForItem items pure $ map packageIndexInfoToValue $ - sort isSearch (boSort browseOptions) $ - packages + sort isSearch (boSort browseOptions) packages where packageIndexInfoToValue :: PackageItem -> Value packageIndexInfoToValue PackageItem{..} = @@ -85,7 +84,7 @@ applyFilter now isSearch coreResource userResource tagsResource DistroFeature{qu filterForItem :: PackageItem -> IO Bool filterForItem item = - all id <$> traverse (includeItem item) filtersWithDefaults + and <$> traverse (includeItem item) filtersWithDefaults sort :: IsSearch -> Sort -> [PackageItem] -> [PackageItem] sort isSearch Sort {sortColumn, sortDirection} = diff --git a/src/Distribution/Server/Features/BuildReports/State.hs b/src/Distribution/Server/Features/BuildReports/State.hs index c742e70b9..0895a95a7 100644 --- a/src/Distribution/Server/Features/BuildReports/State.hs +++ b/src/Distribution/Server/Features/BuildReports/State.hs @@ -1,6 +1,6 @@ {-# LANGUAGE DeriveDataTypeable, TypeFamilies, TemplateHaskell, FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, - TypeOperators, TypeSynonymInstances #-} + TypeOperators #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Distribution.Server.Features.BuildReports.State where @@ -67,7 +67,7 @@ setFailStatus pkgid status = do let reports = BuildReports.setFailStatus pkgid status buildReports State.put reports -resetFailCount :: PackageId -> Update BuildReports (Bool) +resetFailCount :: PackageId -> Update BuildReports Bool resetFailCount pkgid = do buildReports <- State.get case BuildReports.resetFailCount pkgid buildReports of diff --git a/src/Distribution/Server/Features/Core.hs b/src/Distribution/Server/Features/Core.hs index f532eea3b..c6d8835d6 100644 --- a/src/Distribution/Server/Features/Core.hs +++ b/src/Distribution/Server/Features/Core.hs @@ -502,7 +502,7 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..} -- Queries -- queryGetPackageIndex :: MonadIO m => m (PackageIndex PkgInfo) - queryGetPackageIndex = return . packageIndex =<< queryState packagesState GetPackagesState + queryGetPackageIndex = packageIndex <$> queryState packagesState GetPackagesState queryGetIndexTarballInfo :: MonadIO m => m IndexTarballInfo queryGetIndexTarballInfo = readAsyncCache cacheIndexTarball @@ -753,11 +753,11 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..} deauth _ = do return $ (toResponse (""::String)) { rsCode = 401 - , rsHeaders = mkHeaders ([("Content-Type", "text/html")]) + , rsHeaders = mkHeaders [("Content-Type", "text/html")] } packageExists, packageIdExists :: (Package pkg, Package pkg') => PackageIndex pkg -> pkg' -> Bool -- | Whether a package exists in the given package index. packageExists pkgs pkg = not . null $ PackageIndex.lookupPackageName pkgs (packageName pkg) -- | Whether a particular package version exists in the given package index. -packageIdExists pkgs pkg = maybe False (const True) $ PackageIndex.lookupPackageId pkgs (packageId pkg) +packageIdExists pkgs pkg = isJust $ PackageIndex.lookupPackageId pkgs (packageId pkg) diff --git a/src/Distribution/Server/Features/Core/Backup.hs b/src/Distribution/Server/Features/Core/Backup.hs index cecb3ab23..c46f56da7 100644 --- a/src/Distribution/Server/Features/Core/Backup.hs +++ b/src/Distribution/Server/Features/Core/Backup.hs @@ -292,7 +292,7 @@ forceLast :: BS.ByteString -> BS.ByteString forceLast = BS.fromChunks . forceLastBlock . BS.toChunks where forceLastBlock [] = [] - forceLastBlock (c:[]) = c : [] + forceLastBlock [c] = [c] forceLastBlock (c:cs) = c : forceLastBlock cs -------------------------------------------------------------------------------- diff --git a/src/Distribution/Server/Features/Distro.hs b/src/Distribution/Server/Features/Distro.hs index ab38efaf5..785bb5f60 100644 --- a/src/Distribution/Server/Features/Distro.hs +++ b/src/Distribution/Server/Features/Distro.hs @@ -115,10 +115,10 @@ distroFeature UserFeature{..} textEnumDistros _ = fmap (toResponse . intercalate ", " . map display) (queryState distrosState EnumerateDistros) textDistroPkgs dpath = withDistroPath dpath $ \dname pkgs -> do - let pkglines = map (\(name, info) -> display name ++ " at " ++ display (distroVersion info) ++ ": " ++ distroUrl info) $ pkgs + let pkglines = map (\(name, info) -> display name ++ " at " ++ display (distroVersion info) ++ ": " ++ distroUrl info) pkgs return $ toResponse (unlines $ ("Packages for " ++ display dname):pkglines) csvDistroPackageList dpath = withDistroPath dpath $ \_dname pkgs -> do - return $ toResponse $ packageListToCSV $ pkgs + return $ toResponse $ packageListToCSV pkgs textDistroPkg dpath = withDistroPackagePath dpath $ \_ _ info -> return . toResponse $ show info -- result: see-other uri, or an error: not authenticated or not found (todo) @@ -127,7 +127,7 @@ distroFeature UserFeature{..} guardAuthorised_ [InGroup adminGroup] --TODO: use the per-distro maintainer groups -- should also check for existence here of distro here void $ updateState distrosState $ RemoveDistro distro - seeOther ("/distros/") (toResponse ()) + seeOther "/distros/" (toResponse ()) -- result: ok response or not-found error distroPackageDelete dpath = diff --git a/src/Distribution/Server/Features/Documentation.hs b/src/Distribution/Server/Features/Documentation.hs index 1eaa05318..98dcfbd81 100644 --- a/src/Distribution/Server/Features/Documentation.hs +++ b/src/Distribution/Server/Features/Documentation.hs @@ -14,7 +14,7 @@ import Distribution.Server.Features.Users import Distribution.Server.Features.Core import Distribution.Server.Features.TarIndexCache import Distribution.Server.Features.BuildReports -import Distribution.Version ( Version ) +import Distribution.Version (Version, nullVersion) import Distribution.Server.Framework.BackupRestore import qualified Distribution.Server.Framework.ResponseContentTypes as Resource @@ -29,7 +29,6 @@ import qualified Codec.Archive.Tar.Check as Tar import Distribution.Text import Distribution.Package -import Distribution.Version (nullVersion) import qualified Distribution.Parsec as P import qualified Data.ByteString.Char8 as C @@ -113,7 +112,7 @@ documentationStateComponent name stateDir = do } where dumpBackup doc = - let exportFunc (pkgid, blob) = BackupBlob ([display pkgid, "documentation.tar"]) blob + let exportFunc (pkgid, blob) = BackupBlob [display pkgid, "documentation.tar"] blob in map exportFunc . Map.toList $ documentation doc updateDocumentation :: Documentation -> RestoreBackup Documentation @@ -227,7 +226,7 @@ documentationFeature name parseVersion' (Just k) = P.simpleParsec k parsePkgs :: String -> [PackageIdentifier] - parsePkgs pkgsStr = map fromJust $ filter isJust $ map (P.simpleParsec . C.unpack) $ C.split ',' (C.pack pkgsStr) + parsePkgs pkgsStr = mapMaybe (P.simpleParsec . C.unpack) (C.split ',' (C.pack pkgsStr)) isSelectedPackage pkgid pkgid'@(PackageIdentifier _ v) | nullVersion == v = diff --git a/src/Distribution/Server/Features/DownloadCount/State.hs b/src/Distribution/Server/Features/DownloadCount/State.hs index 8c36cfedc..71d47ca68 100644 --- a/src/Distribution/Server/Features/DownloadCount/State.hs +++ b/src/Distribution/Server/Features/DownloadCount/State.hs @@ -19,7 +19,7 @@ import System.Directory ( , createDirectoryIfMissing ) import qualified Data.ByteString.Lazy as BSL -import System.IO (withFile, IOMode (..), hPutStr) +import System.IO (withFile, IOMode (..)) import System.IO.Unsafe (unsafeInterleaveIO) import Text.CSV (printCSV) import Control.Exception (evaluate) @@ -59,7 +59,7 @@ newtype OnDiskStats = OnDiskStats { deriving (Show, Eq, MemSize) instance CountingMap (PackageName, (Day, Version)) OnDiskStats where - cmEmpty = OnDiskStats $ cmEmpty + cmEmpty = OnDiskStats cmEmpty cmTotal (OnDiskStats ncm) = cmTotal ncm cmInsert kl n (OnDiskStats ncm) = OnDiskStats $ cmInsert kl n ncm cmFind k (OnDiskStats ncm) = cmFind k ncm @@ -75,7 +75,7 @@ newtype OnDiskPerPkg = OnDiskPerPkg { deriving (Show, Eq, Ord, MemSize) instance CountingMap (Day, Version) OnDiskPerPkg where - cmEmpty = OnDiskPerPkg $ cmEmpty + cmEmpty = OnDiskPerPkg cmEmpty cmTotal (OnDiskPerPkg ncm) = cmTotal ncm cmInsert kl n (OnDiskPerPkg ncm) = OnDiskPerPkg $ cmInsert kl n ncm cmFind k (OnDiskPerPkg ncm) = cmFind k ncm @@ -90,7 +90,7 @@ newtype RecentDownloads = RecentDownloads { deriving (Show, Eq, MemSize) instance CountingMap PackageName RecentDownloads where - cmEmpty = RecentDownloads $ cmEmpty + cmEmpty = RecentDownloads cmEmpty cmTotal (RecentDownloads ncm) = cmTotal ncm cmInsert kl n (RecentDownloads ncm) = RecentDownloads $ cmInsert kl n ncm cmFind k (RecentDownloads ncm) = cmFind k ncm @@ -105,7 +105,7 @@ newtype TotalDownloads = TotalDownloads { deriving (Show, Eq, MemSize) instance CountingMap PackageName TotalDownloads where - cmEmpty = TotalDownloads $ cmEmpty + cmEmpty = TotalDownloads cmEmpty cmTotal (TotalDownloads ncm) = cmTotal ncm cmInsert kl n (TotalDownloads ncm) = TotalDownloads $ cmInsert kl n ncm cmFind k (TotalDownloads ncm) = cmFind k ncm @@ -233,13 +233,11 @@ writeOnDiskStats stateDir (OnDiskStats (NCM _ onDisk)) = do appendToLog :: FilePath -> InMemStats -> IO () appendToLog stateDir (InMemStats _ inMemStats) = - withFile (stateDir "log") AppendMode $ \h -> - hPutStr h $ printCSV (cmToCSV inMemStats) + appendFile (stateDir "log") $ printCSV (cmToCSV inMemStats) reconstructLog :: FilePath -> OnDiskStats -> IO () reconstructLog stateDir onDisk = - withFile (stateDir "log") WriteMode $ \h -> - hPutStr h $ printCSV (cmToCSV onDisk) + writeFile (stateDir "log") $ printCSV (cmToCSV onDisk) {------------------------------------------------------------------------------ ACID stuff diff --git a/src/Distribution/Server/Features/HaskellPlatform.hs b/src/Distribution/Server/Features/HaskellPlatform.hs index f6623b71f..9d0840bd8 100644 --- a/src/Distribution/Server/Features/HaskellPlatform.hs +++ b/src/Distribution/Server/Features/HaskellPlatform.hs @@ -110,7 +110,7 @@ platformFeature platformState platformVersions pkgname = liftM Set.toList $ queryState platformState $ GetPlatformPackage pkgname platformPackageLatest :: MonadIO m => m [(PackageName, Version)] - platformPackageLatest = liftM (Map.toList . Map.map Set.findMax . blessedPackages) $ queryState platformState $ GetPlatformPackages + platformPackageLatest = liftM (Map.toList . Map.map Set.findMax . blessedPackages) $ queryState platformState GetPlatformPackages setPlatform :: MonadIO m => PackageName -> [Version] -> m () setPlatform pkgname versions = updateState platformState $ SetPlatformPackage pkgname (Set.fromList versions) diff --git a/src/Distribution/Server/Features/Html.hs b/src/Distribution/Server/Features/Html.hs index dd458ddd6..c3165f568 100644 --- a/src/Distribution/Server/Features/Html.hs +++ b/src/Distribution/Server/Features/Html.hs @@ -406,9 +406,9 @@ htmlFeature env@ServerEnv{..} packagesPage :: IO Response packagesPage = do - items <- liftIO $ getAllLists + items <- liftIO getAllLists let htmlpage = - toResponse $ Resource.XHtml $ hackagePage "All packages by name" $ + toResponse $ Resource.XHtml $ hackagePage "All packages by name" [ h2 << "All packages by name" , ulist ! [theclass "packages"] << map renderItem (Map.elems items) ] @@ -952,7 +952,7 @@ mkHtmlDocUploads HtmlUtilities{..} CoreFeature{coreResource} DocumentationFeatur serveUploadDocumentation dpath = do pkgid <- packageInPath dpath uploadDocumentation dpath >> ignoreFilters -- Override 204 No Content - return $ toResponse $ Resource.XHtml $ hackagePage "Documentation uploaded" $ + return $ toResponse $ Resource.XHtml $ hackagePage "Documentation uploaded" [ paragraph << [toHtml "Successfully uploaded documentation for ", packageLink pkgid, toHtml "!"] ] @@ -960,7 +960,7 @@ mkHtmlDocUploads HtmlUtilities{..} CoreFeature{coreResource} DocumentationFeatur serveDeleteDocumentation dpath = do pkgid <- packageInPath dpath deleteDocumentation dpath >> ignoreFilters -- Override 204 No Content - return $ toResponse $ Resource.XHtml $ hackagePage "Documentation deleted" $ + return $ toResponse $ Resource.XHtml $ hackagePage "Documentation deleted" [ paragraph << [toHtml "Successfully deleted documentation for ", packageLink pkgid, toHtml "!"] ] @@ -1006,7 +1006,7 @@ mkHtmlReports HtmlUtilities{..} CoreFeature{..} ReportsFeature{..} templates = H Nothing -> "Not yet tried." Just BR.BuildOK -> "Built successfully." Just (BR.BuildFailCnt 1) -> "1 consecutive failure." - Just (BR.BuildFailCnt c) -> show(c) ++ " consecutive failures." + Just (BR.BuildFailCnt c) -> show c ++ " consecutive failures." return $ toResponse $ template [ "pkgid" $= (pkgid :: PackageIdentifier) , "reports" $= reports @@ -1280,11 +1280,11 @@ mkHtmlCandidates utilities@HtmlUtilities{..} [] -> [ toHtml "No candidates exist for ", packageNameLink pkgname, toHtml ". Upload one for " , anchor ! [href $ renderResource candPkgUp [display pkgname]] << "this" , toHtml " or " - , anchor ! [href $ "/packages/candidates/upload"] << "another" + , anchor ! [href "/packages/candidates/upload"] << "another" , toHtml " package?" ] _ -> [ unordList $ flip map pkgs $ \pkg -> anchor ! [href $ corePackageIdUri candidatesCore "" $ packageId pkg] << display (packageVersion pkg) - , anchor ! [href $ delUri]<< "Delete All Candidates"] + , anchor ! [href delUri]<< "Delete All Candidates"] servePostPublish :: DynamicPath -> ServerPartE Response servePostPublish dpath = do @@ -1317,7 +1317,7 @@ mkHtmlCandidates utilities@HtmlUtilities{..} serveCandUploadDocumentation dpath = do pkgid <- packageInPath dpath uploadDocumentation dpath >> ignoreFilters -- Override 204 No Content - return $ toResponse $ Resource.XHtml $ hackagePage "Documentation uploaded" $ + return $ toResponse $ Resource.XHtml $ hackagePage "Documentation uploaded" [ paragraph << [toHtml "Successfully uploaded documentation for ", candidateLink pkgid, toHtml "!"] ] @@ -1325,7 +1325,7 @@ mkHtmlCandidates utilities@HtmlUtilities{..} serveCandDeleteDocumentation dpath = do pkgid <- packageInPath dpath deleteDocumentation dpath >> ignoreFilters -- Override 204 No Content - return $ toResponse $ Resource.XHtml $ hackagePage "Documentation deleted" $ + return $ toResponse $ Resource.XHtml $ hackagePage "Documentation deleted" [ paragraph << [toHtml "Successfully deleted documentation for ", candidateLink pkgid, toHtml "!"] ] @@ -1448,7 +1448,7 @@ mkHtmlPreferred HtmlUtilities{..} packagePrefAbout maybeEdit pkgname = [ paragraph << [ anchor ! [href $ preferredUri versions ""] << "Preferred and deprecated versions" - , toHtml $ " can be used to influence Cabal's decisions about which versions of " + , toHtml " can be used to influence Cabal's decisions about which versions of " , packageNameLink pkgname , toHtml " to install. If a range of versions is preferred, it means that the installer won't install a non-preferred package version unless it is explicitly specified or if it's the only choice the installer has. Deprecating a version adds a range which excludes just that version. All of this information is collected in the " , anchor ! [href "/packages/preferred-versions"] << "preferred-versions" @@ -1582,7 +1582,7 @@ mkHtmlDownloads HtmlUtilities{..} DownloadFeature{..} = HtmlDownloads{..} serveDownloadTop :: DynamicPath -> ServerPartE Response serveDownloadTop _ = do pkgList <- sortedPackages `liftM` recentPackageDownloads - return $ toResponse $ Resource.XHtml $ hackagePage "Total downloads" $ + return $ toResponse $ Resource.XHtml $ hackagePage "Total downloads" [ h2 << "Downloaded packages" , thediv << table << downTableRows pkgList ] @@ -1591,7 +1591,7 @@ mkHtmlDownloads HtmlUtilities{..} DownloadFeature{..} = HtmlDownloads{..} [ tr << [ th << "Package name", th << "Downloads" ] ] ++ [ tr ! [theclass (if odd n then "odd" else "even")] << [ td << packageNameLink pkgname - , td << [ toHtml $ (show count) ] ] + , td << [ toHtml $ show count ] ] | ((pkgname, count), n) <- zip pkgList [(1::Int)..] ] sortedPackages :: RecentDownloads -> [(PackageName, Int)] @@ -1657,7 +1657,7 @@ mkHtmlTags HtmlUtilities{..} tagList <- queryGetTagList let withCounts = filter ((>0) . snd) . map (\(tg, pkgs) -> (tg, Set.size pkgs)) $ tagList countSort = sortBy (flip compare `on` snd) withCounts - return $ toResponse $ Resource.XHtml $ hackagePage "Hackage tags" $ + return $ toResponse $ Resource.XHtml $ hackagePage "Hackage tags" [ h2 << "Hackage tags" , h4 << "By name" , paragraph ! [theclass "toc"] << (intersperse (toHtml ", ") $ map (tagItem . fst) withCounts) diff --git a/src/Distribution/Server/Features/LegacyPasswds.hs b/src/Distribution/Server/Features/LegacyPasswds.hs index 3c64cea71..d167e9e1a 100644 --- a/src/Distribution/Server/Features/LegacyPasswds.hs +++ b/src/Distribution/Server/Features/LegacyPasswds.hs @@ -152,7 +152,7 @@ updatePasswdsBackup upasswds = RestoreBackup { } importHtPasswds :: CSV -> Restore [(UserId, LegacyAuth.HtPasswdHash)] -importHtPasswds = sequence . map fromRecord . drop 2 +importHtPasswds = mapM fromRecord . drop 2 where fromRecord :: Record -> Restore (UserId, LegacyAuth.HtPasswdHash) fromRecord [idStr, htpasswdStr] = do diff --git a/src/Distribution/Server/Features/LegacyRedirects.hs b/src/Distribution/Server/Features/LegacyRedirects.hs index 1eaf9f9ae..5d1152141 100644 --- a/src/Distribution/Server/Features/LegacyRedirects.hs +++ b/src/Distribution/Server/Features/LegacyRedirects.hs @@ -42,11 +42,11 @@ legacyRedirectsFeature upload = (emptyHackageFeature "legacy") { serveLegacyPosts :: UploadFeature -> ServerPartE Response serveLegacyPosts upload = msum [ dir "packages" $ msum - [ dir "upload" $ movedUpload + [ dir "upload" movedUpload --, postedMove "check" "/check" ] , dir "cgi-bin" $ dir "hackage-scripts" $ msum - [ dir "protected" $ dir "upload-pkg" $ movedUpload + [ dir "protected" $ dir "upload-pkg" movedUpload --, postedMove "check" "/check" ] , dir "upload" movedUpload @@ -67,7 +67,7 @@ serveLegacyGets = msum [ simpleMove "00-index.tar.gz" "/packages/index.tar.gz" , simpleMove "00-index.tar" "/packages/index.tar" , dir "packages" $ msum - [ dir "archive" $ serveArchiveTree + [ dir "archive" serveArchiveTree , simpleMove "hackage.html" "/" , simpleMove "00-index.tar.gz" "/packages/index.tar.gz" --also search.html, advancedsearch.html, accounts.html, and admin.html diff --git a/src/Distribution/Server/Features/Mirror.hs b/src/Distribution/Server/Features/Mirror.hs index 9ffd0edff..1f49c3c7d 100644 --- a/src/Distribution/Server/Features/Mirror.hs +++ b/src/Distribution/Server/Features/Mirror.hs @@ -248,7 +248,7 @@ mirrorFeature ServerEnv{serverBlobStore = store} let uploadData = (time, uid) filename = display pkgid <.> "cabal" - case runParseResult $ parseGenericPackageDescription $ BS.L.toStrict $ fileContent of + case runParseResult $ parseGenericPackageDescription $ BS.L.toStrict fileContent of (_, Left (_, err NE.:| _)) -> badRequest (toResponse $ showPError filename err) (_, Right pkg) | pkgid /= packageId pkg -> errBadRequest "Wrong package Id" diff --git a/src/Distribution/Server/Features/PackageCandidates.hs b/src/Distribution/Server/Features/PackageCandidates.hs index 70500489d..9bb3ba077 100644 --- a/src/Distribution/Server/Features/PackageCandidates.hs +++ b/src/Distribution/Server/Features/PackageCandidates.hs @@ -359,7 +359,7 @@ candidatesFeature ServerEnv{serverBlobStore = store} pkgname <- packageInPath dpath guardAuthorisedAsMaintainerOrTrustee pkgname void $ updateState candidatesState $ DeleteCandidates pkgname - seeOther (packageCandidatesUri candidatesResource "" $ pkgname) $ toResponse () + seeOther (packageCandidatesUri candidatesResource "" pkgname) $ toResponse () serveCandidateTarball :: DynamicPath -> ServerPartE Response serveCandidateTarball dpath = do @@ -507,9 +507,7 @@ candidatesFeature ServerEnv{serverBlobStore = store} candVersion = packageVersion candidate candName = packageName candidate - caseClash pkgs' = [MText $ - "Package(s) with the same name as this package, modulo case, already exist: " - ] + caseClash pkgs' = [MText "Package(s) with the same name as this package, modulo case, already exist: "] ++ intersperse (MText ", ") [ MLink pn ("/package/" ++ pn) | pn <- map (display . packageName) pkgs' ] ++ [MText $ diff --git a/src/Distribution/Server/Features/PackageInfoJSON/State.hs b/src/Distribution/Server/Features/PackageInfoJSON/State.hs index 0cc8b8576..54227d206 100644 --- a/src/Distribution/Server/Features/PackageInfoJSON/State.hs +++ b/src/Distribution/Server/Features/PackageInfoJSON/State.hs @@ -161,7 +161,7 @@ instance Aeson.ToJSON PackageVersions where instance Aeson.FromJSON PackageVersions where parseJSON = Aeson.withObject "PackageVersions" $ \obj -> fmap PackageVersions - $ traverse (parsePair) + $ traverse parsePair $ KeyMap.toList obj where parsePair (vStr, vStatus) = @@ -178,9 +178,9 @@ instance Aeson.FromJSON PackageVersions where "normal" -> return Preferred.NormalVersion "deprecated" -> return Preferred.DeprecatedVersion "unpreferred" -> return Preferred.UnpreferredVersion - other -> fail $ concat ["Could not parse \"" ++ other + other -> fail $ "Could not parse \"" ++ other ++ "\" as status. Expected \"normal\"" - ++ "\"deprecated\" or \"unpreferred\""] + ++ "\"deprecated\" or \"unpreferred\"" parseStatus _ = fail "Expected a string" data PackageInfoState = PackageInfoState { diff --git a/src/Distribution/Server/Features/PackageList.hs b/src/Distribution/Server/Features/PackageList.hs index 4e358fc38..1a719fc22 100644 --- a/src/Distribution/Server/Features/PackageList.hs +++ b/src/Distribution/Server/Features/PackageList.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RankNTypes, NamedFieldPuns, RecordWildCards #-} +{-# LANGUAGE RankNTypes, RecordWildCards #-} module Distribution.Server.Features.PackageList ( ListFeature(..), initListFeature, @@ -32,7 +32,7 @@ import Distribution.PackageDescription.Configuration import Distribution.Utils.ShortText (fromShortText) import Control.Concurrent -import Data.Maybe (catMaybes) +import Data.Maybe (mapMaybe) import Data.Map (Map) import qualified Data.Map as Map import Data.Set (Set) @@ -271,7 +271,7 @@ listFeature CoreFeature{..} makeItemList :: [PackageName] -> IO [PackageItem] makeItemList pkgnames = do mainMap <- readMemState itemCache - return $ catMaybes $ map (flip Map.lookup mainMap) pkgnames + return $ mapMaybe (flip Map.lookup mainMap) pkgnames makeItemMap :: Map PackageName a -> IO (Map PackageName (PackageItem, a)) makeItemMap pkgmap = do diff --git a/src/Distribution/Server/Features/PreferredVersions.hs b/src/Distribution/Server/Features/PreferredVersions.hs index 99ad53e9a..860c9b7c7 100644 --- a/src/Distribution/Server/Features/PreferredVersions.hs +++ b/src/Distribution/Server/Features/PreferredVersions.hs @@ -34,7 +34,7 @@ import Control.Applicative (optional) import Data.Aeson (Value(..)) import Data.Function (fix) import Data.List (intercalate, find) -import Data.Maybe (isJust, fromMaybe, catMaybes) +import Data.Maybe (isJust, fromMaybe, catMaybes, mapMaybe) import Data.Time.Clock (getCurrentTime) import qualified Data.Aeson.Key as Key import qualified Data.Aeson.KeyMap as KeyMap @@ -203,7 +203,7 @@ versionsFeature ServerEnv{ serverVerbosity = verbosity } versionType DeprecatedVersion = "deprecated-version" versionType UnpreferredVersion = "unpreferred-version" return . toResponse . object - $ map (\(i, vs) -> (versionType $ i, array $ map (string . display) vs)) + $ map (\(i, vs) -> (versionType i, array $ map (string . display) vs)) $ Map.toList classifiedVersions handlePackagesDeprecatedGet :: DynamicPath -> ServerPartE Response @@ -272,7 +272,7 @@ versionsFeature ServerEnv{ serverVerbosity = verbosity } withPackagePreferred pkgid func = do pkgIndex <- queryGetPackageIndex case PackageIndex.lookupPackageName pkgIndex (packageName pkgid) of - [] -> packageError [MText $ "No such package in package index. ", MLink "Search for related terms instead?" $ "/packages/search?terms=" ++ (display $ pkgName pkgid)] + [] -> packageError [MText "No such package in package index. ", MLink "Search for related terms instead?" $ "/packages/search?terms=" ++ (display $ pkgName pkgid)] pkgs | pkgVersion pkgid == nullVersion -> queryState preferredState (GetPreferredInfo $ packageName pkgid) >>= \info -> do let rangeToCheck = sumRange info case maybe id (\r -> filter (flip withinRange r . packageVersion)) rangeToCheck pkgs of @@ -319,7 +319,7 @@ versionsFeature ServerEnv{ serverVerbosity = verbosity } updateIndexPackagePreferredVersions :: MonadIO m => PackageName -> PreferredInfo -> m () updateIndexPackagePreferredVersions pkgname prefinfo = do - now <- liftIO $ getCurrentTime + now <- liftIO getCurrentTime let prefEntryName = display pkgname "preferred-versions" prefContent = fromMaybe "" $ formatSinglePreferredVersions pkgname prefinfo @@ -334,10 +334,10 @@ versionsFeature ServerEnv{ serverVerbosity = verbosity } case isDepr of Just {} -> do depr <- optional $ fmap words $ look "by" - case sequence . map simpleParse =<< depr of + case mapM simpleParse =<< depr of Just deprs -> case filter (null . PackageIndex.lookupPackageName index) deprs of - [] -> case any (== pkgname) deprs of - True -> deprecatedError $ "You can not deprecate a package in favor of itself!" + [] -> case pkgname `elem` deprs of + True -> deprecatedError "You can not deprecate a package in favor of itself!" _ -> do doUpdates (Just deprs) return True @@ -351,7 +351,7 @@ versionsFeature ServerEnv{ serverVerbosity = verbosity } doUpdates deprs = do void $ updateState preferredState $ SetDeprecatedFor pkgname deprs runHook_ deprecatedHook (pkgname, deprs) - liftIO $ updateDeprecatedTags + liftIO updateDeprecatedTags renderPrefInfo :: PreferredInfo -> PreferredRender renderPrefInfo pref = PreferredRender { @@ -391,7 +391,7 @@ versionsFeature ServerEnv{ serverVerbosity = verbosity } formatGlobalPreferredVersions :: [(PackageName, PreferredInfo)] -> String formatGlobalPreferredVersions = unlines . (topText++) - . catMaybes . map (uncurry formatSinglePreferredVersions) + . mapMaybe (uncurry formatSinglePreferredVersions) where topText = [ "-- A global set of preferred versions." diff --git a/src/Distribution/Server/Features/PreferredVersions/State.hs b/src/Distribution/Server/Features/PreferredVersions/State.hs index 64a636dc8..d4c389746 100644 --- a/src/Distribution/Server/Features/PreferredVersions/State.hs +++ b/src/Distribution/Server/Features/PreferredVersions/State.hs @@ -239,7 +239,7 @@ findBestVersion info allVersions versions = maxVersion = Set.findMax versions maxAllVersion = last allVersions - newestPreferred = case filter ((==NormalVersion) . (infoMap Map.!)) $ allVersions of + newestPreferred = case filter ((==NormalVersion) . (infoMap Map.!)) allVersions of [] -> Nothing prefs -> Just $ last prefs diff --git a/src/Distribution/Server/Features/ReverseDependencies.hs b/src/Distribution/Server/Features/ReverseDependencies.hs index e31149e50..e25eb5c77 100644 --- a/src/Distribution/Server/Features/ReverseDependencies.hs +++ b/src/Distribution/Server/Features/ReverseDependencies.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RankNTypes, NamedFieldPuns, RecordWildCards #-} +{-# LANGUAGE RankNTypes, RecordWildCards #-} module Distribution.Server.Features.ReverseDependencies ( ReverseFeature, reverseResource, @@ -134,12 +134,12 @@ reverseFeature CoreFeature{..} } reverseResource = fix $ \r -> ReverseResource - { reversePackage = resourceAt ("/package/:package/reverse.:format") - , reversePackageOld = resourceAt ("/package/:package/reverse/old.:format") - , reversePackageAll = resourceAt ("/package/:package/reverse/all.:format") - , reversePackageStats = resourceAt ("/package/:package/reverse/summary.:format") - , reversePackages = resourceAt ("/packages/reverse.:format") - , reversePackagesAll = resourceAt ("/packages/reverse/all.:format") + { reversePackage = resourceAt "/package/:package/reverse.:format" + , reversePackageOld = resourceAt "/package/:package/reverse/old.:format" + , reversePackageAll = resourceAt "/package/:package/reverse/all.:format" + , reversePackageStats = resourceAt "/package/:package/reverse/summary.:format" + , reversePackages = resourceAt "/packages/reverse.:format" + , reversePackagesAll = resourceAt "/packages/reverse/all.:format" , reverseUri = \format pkg -> renderResource (reversePackage r) [display pkg, format] , reverseNameUri = \format pkg -> renderResource (reversePackage r) [display pkg, format] diff --git a/src/Distribution/Server/Features/ReverseDependencies/State.hs b/src/Distribution/Server/Features/ReverseDependencies/State.hs index 7b43ef3a9..4a95db924 100644 --- a/src/Distribution/Server/Features/ReverseDependencies/State.hs +++ b/src/Distribution/Server/Features/ReverseDependencies/State.hs @@ -190,7 +190,7 @@ unregisterPackage getVersions (PackageIdentifier name version) ranges revs = let revPackage = Map.fromList $ map (\v -> (v, pkgMap)) versions revRange = Map.singleton pkgname (Map.fromList $ map (\v -> (v, range)) versions) -- there are possibly better ways to go about this - in Map.differenceWith (\(a, b) (c, d) -> keepMaps $ + in Map.differenceWith (\(a, b) (c, d) -> keepMaps ( Map.differenceWith (\e f -> keepMap $ Map.differenceWith (\g h -> keepSet $ Set.difference g h) @@ -317,7 +317,7 @@ updatePackageReverse indexFunc updated deps revs nameMap = foldl' (\revd pkg -> Map.alter (alterRevDisplay pkg . fromMaybe Map.empty) pkg revd) nameMap deps where lookupVersions :: PackageName -> Set Version - lookupVersions pkgname = maybe Set.empty (Set.unions . map (Map.findWithDefault Set.empty $ updated) . Map.elems . fst) $ Map.lookup pkgname revs + lookupVersions pkgname = maybe Set.empty (Set.unions . map (Map.findWithDefault Set.empty updated) . Map.elems . fst) $ Map.lookup pkgname revs alterRevDisplay :: PackageName -> ReverseDisplay -> Maybe ReverseDisplay alterRevDisplay pkgname rev = keepMap $ updateReverseDisplay indexFunc updated (lookupVersions pkgname) rev diff --git a/src/Distribution/Server/Features/Search.hs b/src/Distribution/Server/Features/Search.hs index 4053375a9..9bae0e2f3 100644 --- a/src/Distribution/Server/Features/Search.hs +++ b/src/Distribution/Server/Features/Search.hs @@ -159,7 +159,7 @@ searchFeature ServerEnv{serverBaseURI} CoreFeature{..} ListFeature{getAllLists} ok (toResponse (toJSON (map packageNameJSON pkgnames))) _ -> - errBadRequest "Invalid search request" [MText $ "Empty terms query"] + errBadRequest "Invalid search request" [MText "Empty terms query"] where packageNameJSON pkgName = object [ Key.fromString "name" .= unPackageName pkgName ] diff --git a/src/Distribution/Server/Features/Search/ExtractDescriptionTerms.hs b/src/Distribution/Server/Features/Search/ExtractDescriptionTerms.hs index e36cd669c..539d3bd14 100644 --- a/src/Distribution/Server/Features/Search/ExtractDescriptionTerms.hs +++ b/src/Distribution/Server/Features/Search/ExtractDescriptionTerms.hs @@ -16,7 +16,6 @@ import Data.Char import qualified NLP.Tokenize as NLP import qualified NLP.Snowball as NLP import qualified Data.Foldable as F -import Data.List (intercalate) import qualified Documentation.Haddock.Markup as Haddock import Documentation.Haddock.Types @@ -64,7 +63,7 @@ extractDescriptionTerms ss stopWords = [] --TODO: something here ( filter (not . ignoreTok) . NLP.tokenize - . intercalate " " . Haddock.markup termsMarkup) + . unwords . Haddock.markup termsMarkup) . Haddock.parse termsMarkup :: DocMarkupH () String [String] diff --git a/src/Distribution/Server/Features/Search/PkgSearch.hs b/src/Distribution/Server/Features/Search/PkgSearch.hs index 46c46d571..9465986d9 100644 --- a/src/Distribution/Server/Features/Search/PkgSearch.hs +++ b/src/Distribution/Server/Features/Search/PkgSearch.hs @@ -12,7 +12,7 @@ import Distribution.Server.Features.Search.ExtractDescriptionTerms import Data.Ix import Data.Set (Set) import qualified Data.Set as Set -import Data.Text (Text) +import Data.Text (Text, unpack) import qualified Data.Text as T import NLP.Snowball @@ -20,7 +20,6 @@ import Distribution.Package import Distribution.PackageDescription import Distribution.Utils.ShortText import Distribution.Text (display) -import Data.Text (unpack) type PkgSearchEngine = SearchEngine diff --git a/src/Distribution/Server/Features/Security/Orphans.hs b/src/Distribution/Server/Features/Security/Orphans.hs index 991a79ffe..14c76b860 100644 --- a/src/Distribution/Server/Features/Security/Orphans.hs +++ b/src/Distribution/Server/Features/Security/Orphans.hs @@ -73,10 +73,10 @@ instance MemSize (Some Sec.Key) where instance MemSize (Sec.Key typ) where memSize (Sec.KeyEd25519 pub pri) = memSize pub + memSize pri -instance MemSize (Ed25519.PublicKey) where +instance MemSize Ed25519.PublicKey where memSize = memSize . Ed25519.unPublicKey -instance MemSize (Ed25519.SecretKey) where +instance MemSize Ed25519.SecretKey where memSize = memSize . Ed25519.unSecretKey instance MemSize Sec.FileVersion where diff --git a/src/Distribution/Server/Features/TarIndexCache/State.hs b/src/Distribution/Server/Features/TarIndexCache/State.hs index 108305b12..0dc62cc22 100644 --- a/src/Distribution/Server/Features/TarIndexCache/State.hs +++ b/src/Distribution/Server/Features/TarIndexCache/State.hs @@ -33,7 +33,7 @@ instance MemSize TarIndexCache where memSize st = 2 + memSize (tarIndexCacheMap st) initialTarIndexCache :: TarIndexCache -initialTarIndexCache = TarIndexCache (Map.empty) +initialTarIndexCache = TarIndexCache Map.empty getTarIndexCache :: Query TarIndexCache TarIndexCache getTarIndexCache = ask diff --git a/src/Distribution/Server/Features/Upload.hs b/src/Distribution/Server/Features/Upload.hs index 2067c3575..c63ae5a95 100644 --- a/src/Distribution/Server/Features/Upload.hs +++ b/src/Distribution/Server/Features/Upload.hs @@ -391,7 +391,7 @@ uploadFeature ServerEnv{serverBlobStore = store} "You are not an authorized package uploader. Please contact the server " ++ "trustees to request to be added to the Uploaders group." ] - caseClash pkgs = [MText $ + caseClash pkgs = [MText "Package(s) with the same name as this package, modulo case, already exist: " ] ++ intersperse (MText ", ") [ MLink pn ("/package/" ++ pn) diff --git a/src/Distribution/Server/Features/Upload/Backup.hs b/src/Distribution/Server/Features/Upload/Backup.hs index 1249a39f7..cabbd9796 100644 --- a/src/Distribution/Server/Features/Upload/Backup.hs +++ b/src/Distribution/Server/Features/Upload/Backup.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE PatternGuards #-} - module Distribution.Server.Features.Upload.Backup ( maintainerBackup, maintToExport, @@ -39,7 +37,7 @@ updateMaintainers mains = RestoreBackup { _ -> return (updateMaintainers mains) , restoreFinalize = - return $ PackageMaintainers (mains) + return $ PackageMaintainers mains } importMaintainers :: CSV -> Map PackageName UserIdSet -> Restore (Map PackageName UserIdSet) diff --git a/src/Distribution/Server/Features/UserSignup.hs b/src/Distribution/Server/Features/UserSignup.hs index 2689572c4..4efe78682 100644 --- a/src/Distribution/Server/Features/UserSignup.hs +++ b/src/Distribution/Server/Features/UserSignup.hs @@ -202,7 +202,7 @@ signupResetBackup = go [] } importSignupInfo :: CSV -> Restore [(Nonce, SignupResetInfo)] -importSignupInfo = sequence . map fromRecord . drop 2 +importSignupInfo = mapM fromRecord . drop 2 where fromRecord :: Record -> Restore (Nonce, SignupResetInfo) fromRecord [nonceStr, usernameStr, realnameStr, emailStr, timestampStr] = do @@ -234,7 +234,7 @@ signupInfoToCSV backuptype (SignupResetTable tbl) | (nonce, SignupInfo{..}) <- Map.toList tbl ] importResetInfo :: CSV -> Restore [(Nonce, SignupResetInfo)] -importResetInfo = sequence . map fromRecord . drop 2 +importResetInfo = mapM fromRecord . drop 2 where fromRecord :: Record -> Restore (Nonce, SignupResetInfo) fromRecord [nonceStr, useridStr, timestampStr] = do diff --git a/src/Distribution/Server/Features/Votes/Render.hs b/src/Distribution/Server/Features/Votes/Render.hs index e68f170a6..21a20ecf5 100644 --- a/src/Distribution/Server/Features/Votes/Render.hs +++ b/src/Distribution/Server/Features/Votes/Render.hs @@ -20,13 +20,13 @@ renderVotesAnon numVotes pkgname = form ! [ action $ "/package/" ++ unPackageName pkgname ++ "/votes" , method "POST" ] << thespan << - [ toHtml $ show numVotes ++ " " - , toHtml $ ("[" +++ - hidden "_method" "PUT" +++ + [ toHtml $ show numVotes ++ " " + , toHtml $ "[" +++ + hidden "_method" "PUT" +++ input ! [ thetype "submit" , value "Vote for this package" , theclass "text-button" ] - +++ "]") + +++ "]" ] -- A page that confirms a package was successfully voted for and diff --git a/src/Distribution/Server/Framework/BackupRestore.hs b/src/Distribution/Server/Framework/BackupRestore.hs index cf4efca22..64e5c0bfa 100644 --- a/src/Distribution/Server/Framework/BackupRestore.hs +++ b/src/Distribution/Server/Framework/BackupRestore.hs @@ -108,9 +108,9 @@ abstractRestoreBackup putSt = go where go RestoreBackup {..} = AbstractRestoreBackup { abstractRestoreEntry = \store entry -> - liftM go <$> (runRestore store $ restoreEntry entry) + fmap go <$> do runRestore store $ restoreEntry entry , abstractRestoreFinalize = \store -> - liftM putSt <$> (runRestore store $ restoreFinalize) + fmap putSt <$> runRestore store restoreFinalize } instance Monoid AbstractRestoreBackup where diff --git a/src/Distribution/Server/Framework/BlobStorage.hs b/src/Distribution/Server/Framework/BlobStorage.hs index 27e57c26e..461afb75c 100644 --- a/src/Distribution/Server/Framework/BlobStorage.hs +++ b/src/Distribution/Server/Framework/BlobStorage.hs @@ -1,5 +1,5 @@ {-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, - ScopedTypeVariables, TypeFamilies, BangPatterns, CPP, + ScopedTypeVariables, TypeFamilies, CPP, RecordWildCards #-} ----------------------------------------------------------------------------- -- | @@ -43,7 +43,7 @@ import qualified Data.ByteString as BSS import qualified Data.ByteString.Lazy as BSL import Data.Serialize import System.FilePath (()) -import Control.Exception (handle, throwIO, evaluate, bracket) +import Control.Exception (handle, throwIO, evaluate) import Data.SafeCopy import System.Directory import System.IO @@ -160,7 +160,7 @@ hBlobId :: Handle -> IO BlobId hBlobId hnd = evaluate . BlobId . md5 =<< BSL.hGetContents hnd fileBlobId :: FilePath -> IO BlobId -fileBlobId file = bracket (openBinaryFile file ReadMode) hClose hBlobId +fileBlobId file = withBinaryFile file ReadMode hBlobId withIncoming :: BlobStorage -> BSL.ByteString -> (FilePath -> BlobId -> IO (a, Bool)) diff --git a/src/Distribution/Server/Framework/Cache.hs b/src/Distribution/Server/Framework/Cache.hs index fedeea00a..7baf050cf 100644 --- a/src/Distribution/Server/Framework/Cache.hs +++ b/src/Distribution/Server/Framework/Cache.hs @@ -108,7 +108,7 @@ newAsyncVar :: Int -> Bool -> Verbosity -> String newAsyncVar delay syncForce verbosity logname force initial = do inChan <- atomically newTChan - outVar <- atomically (newTVar (Right initial)) + outVar <- newTVarIO (Right initial) hook <- newHook if syncForce @@ -152,7 +152,7 @@ newAsyncVar delay syncForce verbosity logname force initial = do readAsyncVar :: AsyncVar state -> IO state readAsyncVar (AsyncVar _ outVar _) = - atomically (readTVar outVar) >>= either E.throwIO return + readTVarIO outVar >>= either E.throwIO return writeAsyncVar :: AsyncVar state -> ProdReason -> state -> IO () writeAsyncVar (AsyncVar inChan _ _) reason value = diff --git a/src/Distribution/Server/Framework/Feature.hs b/src/Distribution/Server/Framework/Feature.hs index 88bc39792..357d9865c 100644 --- a/src/Distribution/Server/Framework/Feature.hs +++ b/src/Distribution/Server/Framework/Feature.hs @@ -1,6 +1,6 @@ -- | This module defines a plugin interface for Hackage features. -- -{-# LANGUAGE ExistentialQuantification, RankNTypes, NoMonomorphismRestriction, RecordWildCards #-} +{-# LANGUAGE ExistentialQuantification, RankNTypes, NoMonomorphismRestriction #-} module Distribution.Server.Framework.Feature ( -- * Main datatypes HackageFeature(..) diff --git a/src/Distribution/Server/Framework/Instances.hs b/src/Distribution/Server/Framework/Instances.hs index 336e474da..442e9c15f 100644 --- a/src/Distribution/Server/Framework/Instances.hs +++ b/src/Distribution/Server/Framework/Instances.hs @@ -1,5 +1,4 @@ -{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving, FlexibleContexts, BangPatterns, - TypeFamilies #-} +{-# LANGUAGE FlexibleContexts, BangPatterns, TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -339,7 +338,7 @@ instance Parsec UTCTime where mtz <- optional (liftM2 (:) (P.satisfy (\c -> Char.isAsciiLower c || Char.isAsciiUpper c || c == '+' || c == '-')) (P.munch (\c -> Char.isAsciiLower c || Char.isAsciiUpper c || Char.isDigit c))) - let tstr = concat [ yyyy, "-", mm, "-", dd, " ", h, ":", m, ":", s, maybe "" id mq, maybe "" (' ':) mtz ] + let tstr = concat [ yyyy, "-", mm, "-", dd, " ", h, ":", m, ":", s, fromMaybe "" mq, maybe "" (' ':) mtz ] case readMaybe tstr of Nothing -> fail "invalid UTCTime" diff --git a/src/Distribution/Server/Framework/RequestContentTypes.hs b/src/Distribution/Server/Framework/RequestContentTypes.hs index a747efe3e..d3a0311dc 100644 --- a/src/Distribution/Server/Framework/RequestContentTypes.hs +++ b/src/Distribution/Server/Framework/RequestContentTypes.hs @@ -64,7 +64,7 @@ expectContentType expected = do ++ BS.unpack expected ++ ", rather than " ++ BS.unpack actual] wrongContentEncoding = errBadMediaType "Unexpected content-encoding" - [MText $ "The only content-encodings supported are gzip, or none at all."] + [MText "The only content-encodings supported are gzip, or none at all."] gzipDecompress :: LBS.ByteString -> ServerPartE LBS.ByteString gzipDecompress content = go content decompressor diff --git a/src/Distribution/Server/Framework/Resource.hs b/src/Distribution/Server/Framework/Resource.hs index 3ccddfbe2..6080844e5 100644 --- a/src/Distribution/Server/Framework/Resource.hs +++ b/src/Distribution/Server/Framework/Resource.hs @@ -1,5 +1,4 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving, - FlexibleContexts, FlexibleInstances, NamedFieldPuns #-} +{-# LANGUAGE FlexibleContexts, FlexibleInstances, NamedFieldPuns #-} module Distribution.Server.Framework.Resource ( -- | Paths @@ -44,11 +43,10 @@ import Distribution.Server.Framework.HappstackUtils (remainingPathString, uriEsc import Distribution.Server.Util.ContentType (parseContentAccept) import Distribution.Server.Framework.Error -import Data.List (isSuffixOf) import Data.Map (Map) import qualified Data.Map as Map import Data.Function (on) -import Data.List (intercalate, unionBy, findIndices, find) +import Data.List (intercalate, unionBy, elemIndices, find, isSuffixOf) import qualified Text.ParserCombinators.Parsec as Parse import System.FilePath.Posix ((), (<.>)) @@ -189,7 +187,7 @@ extendResourcePath arg resource = ResourceFormat NoFormat Nothing -> case loc of (TrailingBranch:rest) -> rest _ -> loc - _ -> funcError $ "invalid resource format in argument 2" + _ -> funcError "invalid resource format in argument 2" in extendResource resource { resourceLocation = reverse loc' ++ endLoc, resourceFormat = format', resourcePathEnd = slash' } where @@ -499,7 +497,7 @@ serveResource errRes (Resource _ rget rput rpost rdelete rformat rend _) = \dpat (pname', format') = splitAt (length pname - fsize - 1) pname in if '.':format == format' then Just pname' else Nothing - extractExt pname = case findIndices (=='.') pname of + extractExt pname = case elemIndices '.' pname of [] -> (pname, "") xs -> case splitAt (last xs) pname of (pname', _:format) -> (pname', format) _ -> (pname, "") -- this shouldn't happen diff --git a/src/Distribution/Server/Framework/ResponseContentTypes.hs b/src/Distribution/Server/Framework/ResponseContentTypes.hs index 1486cad34..f42fee51c 100644 --- a/src/Distribution/Server/Framework/ResponseContentTypes.hs +++ b/src/Distribution/Server/Framework/ResponseContentTypes.hs @@ -1,8 +1,6 @@ -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE StandaloneDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- | diff --git a/src/Distribution/Server/Framework/Templating.hs b/src/Distribution/Server/Framework/Templating.hs index 27cedae31..cbbcfcc2e 100644 --- a/src/Distribution/Server/Framework/Templating.hs +++ b/src/Distribution/Server/Framework/Templating.hs @@ -245,7 +245,7 @@ checkTemplates templateGroup templateDirs expectedTemplates = do when (not (null missing)) $ fail $ "Missing template files: " ++ intercalate ", " (map (<.> "st") missing) - ++ ". Search path was: " ++ intercalate " " templateDirs + ++ ". Search path was: " ++ unwords templateDirs when (not (null problems)) $ fail $ reportTemplateProblems problems diff --git a/src/Distribution/Server/Packages/Index.hs b/src/Distribution/Server/Packages/Index.hs index ddfa08a73..e2f041de8 100644 --- a/src/Distribution/Server/Packages/Index.hs +++ b/src/Distribution/Server/Packages/Index.hs @@ -47,7 +47,7 @@ import qualified Data.Map as Map import qualified Data.Vector as Vec import Data.ByteString.Lazy (ByteString) import System.FilePath.Posix -import Data.Maybe (catMaybes, mapMaybe) +import Data.Maybe (mapMaybe) -- | Entries used to construct the contents of the hackage index tarball @@ -96,7 +96,7 @@ deriveSafeCopy 0 'base ''TarIndexEntry writeIncremental :: PackageIndex PkgInfo -> [TarIndexEntry] -> ByteString writeIncremental pkgs = - Tar.write . catMaybes . map mkTarEntry + Tar.write . mapMaybe mkTarEntry where -- This should never return Nothing, it'd be an internal error but just -- in case we'll skip them diff --git a/src/Distribution/Server/Packages/Metadata.hs b/src/Distribution/Server/Packages/Metadata.hs index d31912b6c..e65b0127f 100644 --- a/src/Distribution/Server/Packages/Metadata.hs +++ b/src/Distribution/Server/Packages/Metadata.hs @@ -1,5 +1,4 @@ {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE NamedFieldPuns #-} -- | Constructing TUF package metadata module Distribution.Server.Packages.Metadata ( computePkgMetadata diff --git a/src/Distribution/Server/Packages/PackageIndex.hs b/src/Distribution/Server/Packages/PackageIndex.hs index 312bd3003..4b862d649 100644 --- a/src/Distribution/Server/Packages/PackageIndex.hs +++ b/src/Distribution/Server/Packages/PackageIndex.hs @@ -99,7 +99,7 @@ instance Eq pkg => Eq (PackageIndex pkg) where instance Package pkg => Monoid (PackageIndex pkg) where - mempty = PackageIndex (Map.empty) + mempty = PackageIndex Map.empty mappend = (<>) --save one mappend with empty in the common case: mconcat [] = mempty diff --git a/src/Distribution/Server/Packages/Render.hs b/src/Distribution/Server/Packages/Render.hs index 34241afda..09c0577da 100644 --- a/src/Distribution/Server/Packages/Render.hs +++ b/src/Distribution/Server/Packages/Render.hs @@ -41,7 +41,6 @@ import Distribution.Types.VersionInterval.Legacy -- I criticized this unfortunate development at length at: -- https://github.com/haskell/cabal/issues/7916 import Distribution.ModuleName as ModuleName -import Distribution.Types.ModuleReexport -- hackage-server import Distribution.Server.Framework.CacheControl (ETag) diff --git a/src/Distribution/Server/Pages/Group.hs b/src/Distribution/Server/Pages/Group.hs index 4007e0207..3afc3a035 100644 --- a/src/Distribution/Server/Pages/Group.hs +++ b/src/Distribution/Server/Pages/Group.hs @@ -12,7 +12,6 @@ import qualified Distribution.Server.Users.Types as Users import Distribution.Server.Users.Group (GroupDescription(..)) import qualified Distribution.Server.Users.Group as Group import Distribution.Text -import Data.Maybe renderGroupName :: GroupDescription -> Maybe String -> Html renderGroupName desc murl = @@ -73,4 +72,4 @@ listGroup :: [Users.UserName] -> Maybe String -> Html listGroup [] _ = p << "No member exist presently" listGroup users muri = unordList (map displayName users) where displayName uname = (anchor ! [href $ "/user/" ++ display uname] << display uname) +++ - fromMaybe [] (fmap (removeUser uname) muri) + maybe [] (removeUser uname) muri diff --git a/src/Distribution/Server/Pages/Package/HaddockHtml.hs b/src/Distribution/Server/Pages/Package/HaddockHtml.hs index b919e5f1b..dba250b9f 100644 --- a/src/Distribution/Server/Pages/Package/HaddockHtml.hs +++ b/src/Distribution/Server/Pages/Package/HaddockHtml.hs @@ -27,9 +27,9 @@ htmlMarkup modResolv = Markup { markupOrderedList = ordList, markupDefList = defList, markupCodeBlock = pre, - markupHyperlink = \(Hyperlink url mLabel) -> anchor ! [href url] << fromMaybe url (fmap showHtmlFragment mLabel), + markupHyperlink = \(Hyperlink url mLabel) -> anchor ! [href url] << maybe url showHtmlFragment mLabel, markupAName = \aname -> namedAnchor aname << toHtml "", - markupPic = \(Picture uri mtitle) -> image ! ([src uri] ++ fromMaybe [] (return . title <$> mtitle)), + markupPic = \(Picture uri mtitle) -> image ! (src uri : maybe [] (return . title) mtitle), markupMathInline = \mathjax -> toHtml ("\\(" ++ mathjax ++ "\\)"), markupMathDisplay = \mathjax -> toHtml ("\\[" ++ mathjax ++ "\\]"), markupProperty = pre . toHtml, diff --git a/src/Distribution/Server/Pages/PackageFromTemplate.hs b/src/Distribution/Server/Pages/PackageFromTemplate.hs index 0a7ea9b29..091c953c9 100644 --- a/src/Distribution/Server/Pages/PackageFromTemplate.hs +++ b/src/Distribution/Server/Pages/PackageFromTemplate.hs @@ -1,5 +1,5 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE PatternGuards, RecordWildCards #-} +{-# LANGUAGE PatternGuards #-} module Distribution.Server.Pages.PackageFromTemplate ( packagePageTemplate , candidatesPageTemplate @@ -18,7 +18,7 @@ import qualified Distribution.Server.Packages.PackageIndex as PackageIndex import Distribution.Server.Packages.PackageIndex (PackageIndex) import Distribution.Server.Packages.Types import Distribution.Server.Features.PackageCandidates -import Distribution.Server.Users.Types (userStatus, userName, isActiveAccount) +import Distribution.Server.Users.Types (UserInfo, userStatus, userName, isActiveAccount) import Distribution.Server.Util.Markdown (renderMarkdown, supposedToBeMarkdown) import Data.TarIndex (TarIndex) import Distribution.Server.Features.Distro.Types @@ -44,7 +44,6 @@ import qualified Data.ByteString.Lazy as BS (ByteString, toStrict) import qualified Distribution.Server.Pages.Package as Old import Data.Time.Clock (UTCTime) -import Distribution.Server.Users.Types (UserInfo) import Distribution.Server.Features.Html.HtmlUtilities @@ -161,7 +160,7 @@ packagePageTemplate render -- Fields from the .cabal file. -- Access via "$package.varName$" - packageFieldsTemplate = templateDict $ + packageFieldsTemplate = templateDict [ templateVal "name" pkgName , templateVal "version" pkgVer , templateVal "license" (Old.rendLicense render) @@ -176,8 +175,8 @@ packagePageTemplate render docFieldsTemplate = if isCandidate - then templateDict $ [ templateVal "baseUrl" docURL ] - else templateDict $ [ templateVal "hasQuickNavV1" hasQuickNavV1 + then templateDict [ templateVal "baseUrl" docURL ] + else templateDict [ templateVal "hasQuickNavV1" hasQuickNavV1 , templateVal "baseUrl" docURL ] diff --git a/src/Distribution/Server/Pages/Recent.hs b/src/Distribution/Server/Pages/Recent.hs index a648c4e00..03abd53c4 100644 --- a/src/Distribution/Server/Pages/Recent.hs +++ b/src/Distribution/Server/Pages/Recent.hs @@ -131,7 +131,7 @@ recentFeed users hostURI now pkgs = RSS desc = "The 20 most recent additions to 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 > 20) then pkgListTwoDays else take 20 pkgs + pkgList = if length pkgListTwoDays > 20 then pkgListTwoDays else take 20 pkgs updated = maybe now (fst . pkgOriginalUploadInfo) (listToMaybe pkgList) recentRevisionsFeed :: Users -> URI -> UTCTime -> [PkgInfo] -> RSS diff --git a/src/Distribution/Server/Pages/Reverse.hs b/src/Distribution/Server/Pages/Reverse.hs index 35d110391..69a371c0a 100644 --- a/src/Distribution/Server/Pages/Reverse.hs +++ b/src/Distribution/Server/Pages/Reverse.hs @@ -36,7 +36,7 @@ reversePackageRender pkgid packageLink r isRecent (ReversePageRender renders cou versionBox = if hasVersion && total /= allCounts then thediv ! [theclass "notification"] << [toHtml $ "These statistics only apply to this version of " ++ display pkgname ++ ". See also ", anchor ! [href $ reverseNameUri r "" pkgname] << [toHtml "packages which depend on ", emphasize << "any", toHtml " version"], toHtml $ " (all " ++ show total ++ " of them)."] else noHtml - allCounts = fst counts + snd counts + allCounts = uncurry (+) counts otherCount = case total - allCounts of diff | diff > 0 -> paragraph << [show diff ++ " packages depend on versions of " ++ display pkgid ++ " other than this one."] _ -> noHtml @@ -96,7 +96,7 @@ reverseFlatRender pkgname packageLink r (ReverseCount total flat _) pairs = _ -> [ paragraph << if total == flat then [toHtml "All packages which use ", toPackage pkgname, toHtml " depend on it ", anchor ! [href $ reverseNameUri r "" pkgname] << "directly", toHtml $ ". " ++ onlyPackage total] - else [toPackage pkgname, toHtml $ " has ", anchor ! [href $ reverseNameUri r "" pkgname] << num total "packages" "package", toHtml $ " which directly " ++ num' total "depend" "depends" ++ " on it, but there are more packages which depend on ", emphasize << "those", toHtml $ " packages. If you flatten the tree of reverse dependencies, you'll find " ++ show flat ++ " packages which use " ++ display pkgname ++ ", and " ++ show (flat-total) ++ " which do so without depending directly on it. All of these packages are listed below."] + else [toPackage pkgname, toHtml " has ", anchor ! [href $ reverseNameUri r "" pkgname] << num total "packages" "package", toHtml $ " which directly " ++ num' total "depend" "depends" ++ " on it, but there are more packages which depend on ", emphasize << "those", toHtml $ " packages. If you flatten the tree of reverse dependencies, you'll find " ++ show flat ++ " packages which use " ++ display pkgname ++ ", and " ++ show (flat-total) ++ " which do so without depending directly on it. All of these packages are listed below."] , paragraph << [toHtml "See also the ", anchor ! [href $ reverseStatsUri r "" pkgname] << "statistics for specific versions", toHtml $ " of " ++ display pkgname ++ "."] , reverseTable ] @@ -151,7 +151,7 @@ num' n plural singular = if n == 1 then singular else plural -- /packages/reverse reversePackagesRender :: (PackageName -> String) -> ReverseResource -> Int -> [(PackageName, Int, Int)] -> [Html] reversePackagesRender packageLink r pkgCount triples = - h2 << ("Reverse dependencies") : + h2 << "Reverse dependencies" : [ paragraph << [ "Hackage has " ++ show pkgCount ++ " packages. Here are all the packages that have package that depend on them:"] , reverseTable ] where diff --git a/src/Distribution/Server/Users/AuthToken.hs b/src/Distribution/Server/Users/AuthToken.hs index 903ab9799..019439569 100644 --- a/src/Distribution/Server/Users/AuthToken.hs +++ b/src/Distribution/Server/Users/AuthToken.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, TemplateHaskell #-} +{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeFamilies #-} module Distribution.Server.Users.AuthToken ( AuthToken diff --git a/src/Distribution/Server/Users/State.hs b/src/Distribution/Server/Users/State.hs index 7d1759982..d828c62db 100644 --- a/src/Distribution/Server/Users/State.hs +++ b/src/Distribution/Server/Users/State.hs @@ -1,6 +1,6 @@ {-# LANGUAGE DeriveDataTypeable, TypeFamilies, TemplateHaskell, FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, - TypeOperators, TypeSynonymInstances #-} + TypeOperators #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Distribution.Server.Users.State where diff --git a/src/Distribution/Server/Util/CabalRevisions.hs b/src/Distribution/Server/Util/CabalRevisions.hs index 9947eff2e..6f4633468 100644 --- a/src/Distribution/Server/Util/CabalRevisions.hs +++ b/src/Distribution/Server/Util/CabalRevisions.hs @@ -357,8 +357,8 @@ checkPackageDescriptions checkXRevision extraDocFilesA extraDocFilesB checkSame "Cannot change custom/extension fields" - (filter (\(f,_) -> not (f `elem` ["x-revision","x-curation"])) customFieldsPDA) - (filter (\(f,_) -> not (f `elem` ["x-revision","x-curation"])) customFieldsPDB) + (filter (\(f,_) -> f `notElem` ["x-revision","x-curation"]) customFieldsPDA) + (filter (\(f,_) -> f `notElem` ["x-revision","x-curation"]) customFieldsPDB) checkSpecVersionRaw pdA pdB checkSetupBuildInfo setupBuildInfoA setupBuildInfoB @@ -573,15 +573,15 @@ checkSetupBuildInfo (Just _) Nothing = checkSetupBuildInfo Nothing (Just (SetupBuildInfo setupDependsA _internalA)) = logChange $ Change Normal - ("added a 'custom-setup' section with 'setup-depends'") + "added a 'custom-setup' section with 'setup-depends'" "[implicit]" (intercalate ", " (map prettyShow setupDependsA)) checkSetupBuildInfo (Just (SetupBuildInfo setupDependsA _internalA)) (Just (SetupBuildInfo setupDependsB _internalB)) = do forM_ removed $ \dep -> - logChange $ Change Normal ("removed 'custom-setup' dependency on") (prettyShow dep) "" + logChange $ Change Normal "removed 'custom-setup' dependency on" (prettyShow dep) "" forM_ added $ \dep -> - logChange $ Change Normal ("added 'custom-setup' dependency on") "" (prettyShow dep) + logChange $ Change Normal "added 'custom-setup' dependency on" "" (prettyShow dep) forM_ changed $ \(pkgn, (verA, verB)) -> changesOk ("the 'custom-setup' dependency on " ++ prettyShow'' pkgn) prettyShow verA verB diff --git a/src/Distribution/Server/Util/CountingMap.hs b/src/Distribution/Server/Util/CountingMap.hs index 15e587d15..af1153cda 100644 --- a/src/Distribution/Server/Util/CountingMap.hs +++ b/src/Distribution/Server/Util/CountingMap.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, UndecidableInstances, DeriveDataTypeable, ScopedTypeVariables #-} +{-# LANGUAGE FunctionalDependencies, FlexibleInstances, UndecidableInstances, DeriveDataTypeable, ScopedTypeVariables #-} module Distribution.Server.Util.CountingMap ( NestedCountingMap(..) , SimpleCountingMap(..) diff --git a/src/Distribution/Server/Util/SigTerm.hs b/src/Distribution/Server/Util/SigTerm.hs index e05f7a910..18a613aeb 100644 --- a/src/Distribution/Server/Util/SigTerm.hs +++ b/src/Distribution/Server/Util/SigTerm.hs @@ -10,13 +10,10 @@ import System.Posix.Signals import Control.Exception ( AsyncException(UserInterrupt), throwTo ) import Control.Concurrent - ( myThreadId ) -import Control.Concurrent - ( ThreadId, mkWeakThreadId ) -import System.Mem.Weak - ( Weak ) + ( ThreadId, mkWeakThreadId, myThreadId ) import System.Mem.Weak - ( deRefWeak ) + ( Weak , deRefWeak) + -- | On SIGTERM, throw 'UserInterrupt' to the calling thread. -- diff --git a/src/Distribution/Server/Util/TarIndex.hs b/src/Distribution/Server/Util/TarIndex.hs index 1544b38d0..dd9cabfde 100644 --- a/src/Distribution/Server/Util/TarIndex.hs +++ b/src/Distribution/Server/Util/TarIndex.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TemplateHaskell, DeriveDataTypeable, TypeFamilies, TemplateHaskell, +{-# LANGUAGE TemplateHaskell, DeriveDataTypeable, TypeFamilies, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-} -- This is presently unused: features provide their own BlobId-to-TarIndex diff --git a/tests/HighLevelTest.hs b/tests/HighLevelTest.hs index 2063b135f..6ad2d27d5 100644 --- a/tests/HighLevelTest.hs +++ b/tests/HighLevelTest.hs @@ -61,7 +61,7 @@ doit root runUserTests runPackageUploadTests runPackageTests - withServerRunning root $ runPackageTests + withServerRunning root runPackageTests info "Making database backup" tarGz1 <- createBackup testName root "1" info "Removing old state" @@ -82,7 +82,7 @@ doit root db2 <- LBS.readFile tarGz2 unless (db1 == db2) $ die "Databases don't match" info "Checking server still works, and data is intact" - withServerRunning root $ runPackageTests + withServerRunning root runPackageTests runUserTests :: IO () diff --git a/tests/HttpUtils.hs b/tests/HttpUtils.hs index 30b36cbc3..5263dec74 100644 --- a/tests/HttpUtils.hs +++ b/tests/HttpUtils.hs @@ -1,5 +1,5 @@ -- | Generic HTTP utilities -{-# LANGUAGE ViewPatterns, OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -Wall #-} module HttpUtils ( -- * Stateless functions @@ -79,7 +79,7 @@ withAuth (Auth user pass) req f = do | rspCode rsp == (4, 0, 1) -> do let uri = rqURI req hdrs = retrieveHeaders HdrWWWAuthenticate rsp - challenges = catMaybes $ map (headerToChallenge uri) hdrs + challenges = mapMaybe (headerToChallenge uri) hdrs auth <- case challenges of [] -> die "No challenges" diff --git a/tests/MailUtils.hs b/tests/MailUtils.hs index 739a45793..bf83c2465 100644 --- a/tests/MailUtils.hs +++ b/tests/MailUtils.hs @@ -16,6 +16,7 @@ module MailUtils ( ) where import Control.Concurrent (threadDelay) +import Data.Foldable (find) import Data.Maybe import Network.URI import Network.HTTP hiding (user) @@ -65,7 +66,7 @@ checkEmail user = do emailWithSubject :: String -> String -> IO (Maybe Email) emailWithSubject user subject = do emails <- checkEmail user - return . listToMaybe . filter ((== subject) . emailTitle) $ emails + return . find ((== subject) . emailTitle) $ emails waitForEmailWithSubject :: String -> String -> IO Email waitForEmailWithSubject user subject = f 10