Clean up warnings

hackage-server.cabal

@@ -135,6 +135,8 @@ common language-defaults
     -Wno-deprecated-flags
     -Wno-unused-do-bind
     -Wno-unused-record-wildcards
+    -- TODO remove all Typeable derivings and remove this flag. Safe since GHC 7.10
+    -Wno-deriving-typeable
     -Werror=incomplete-patterns
     -Werror=missing-methods
 

src/Data/StringTable.hs

@@ -28,7 +28,7 @@ import Distribution.Server.Framework.MemSize
 data StringTable id
          = StringTable
                !BS.ByteString          -- all the strings concatenated
-               !(A.UArray Int Word32)  -- offset table
+               !(A.UArray Int Word32)  -- ^ Invariant: the lower bound of the array is 0
   deriving (Show, Typeable)
 
 $(deriveSafeCopy 0 'base ''StringTable)
@@ -42,7 +42,7 @@ instance MemSize (StringTable id) where
 lookup :: Enum id => StringTable id -> String -> Maybe id
 lookup (StringTable bs tbl) str = binarySearch 0 (topBound-1) (BS.pack str)
   where
-    (0, topBound) = A.bounds tbl
+    (_assumedZero, topBound) = A.bounds tbl
 
     binarySearch a b key
       | a > b     = Nothing
@@ -81,12 +81,12 @@ construct strs = StringTable bs tbl
 
 enumStrings :: Enum id => StringTable id -> [String]
 enumStrings (StringTable bs tbl) = map (BS.unpack . index' bs tbl) [0..h-1]
-  where (0,h) = A.bounds tbl
+  where (_assumedZero, h) = A.bounds tbl
 
 
 enumIds :: Enum id => StringTable id -> [id]
 enumIds (StringTable _ tbl) = map toEnum [0..h-1]
-  where (0,h) = A.bounds tbl
+  where (_assumedZero, h) = A.bounds tbl
 
 prop :: [String] -> Bool
 prop strs =

src/Distribution/Client.hs

@@ -274,7 +274,7 @@ responseReadBSL rsp =
     traverse (fmap BS.fromChunks . brConsume) rsp
 
 httpSession :: Verbosity -> String -> Version -> HttpSession a -> IO a
-httpSession verbosity agent version (HttpSession action) = do
+httpSession _verbosity agent version (HttpSession action) = do
     manager <- newTlsManager
     let env = HttpEnv { httpManager = manager
                       , initialHeaders = [ (hUserAgent, BSS.pack $ agent ++ "/" ++ showVersion version) ]

src/Distribution/Server/Features/Core.hs

@@ -763,7 +763,8 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..}
 
     serveCabalFileRevisionName :: DynamicPath -> ServerPartE Response
     serveCabalFileRevisionName dpath = do
-      pkgid1 <- packageTarballInPath dpath
+      -- TODO bug? Maybe something to do with #1439
+      _pkgid1 <- packageTarballInPath dpath
       pkgid2 <- packageInPath dpath
       guard (pkgVersion pkgid2 == pkgVersion pkgid2)
       pkginfo <- packageInPath dpath >>= lookupPackageId

src/Distribution/Server/Features/DownloadCount/State.hs

@@ -176,9 +176,9 @@ updateHistory (InMemStats day perPkg) (OnDiskStats (NCM _ m)) =
     updatesMap :: Map.Map PackageName OnDiskPerPkg
     updatesMap = Map.fromList
       [ (pkgname, applyUpdates pkgs)
-      | pkgs <- groupBy ((==) `on` (packageName . fst))
-                        (cmToList perPkg :: [(PackageId, Int)])
-      , let pkgname = packageName (fst (head pkgs))
+      | pkgs@((pkgId, _):_) <- groupBy ((==) `on` (packageName . fst))
+                                (cmToList perPkg :: [(PackageId, Int)])
+      , let pkgname = packageName pkgId
       ]
 
     applyUpdates :: [(PackageId, Int)] -> OnDiskPerPkg

src/Distribution/Server/Features/EditCabalFiles.hs

@@ -168,6 +168,6 @@ instance ToSElem Change where
     where
       -- TODO/FIXME: stringly hack
       what = case what0 of
-        ('a':'d':'d':'e':'d':_)         -> 'A' : tail what0
-        ('r':'e':'m':'o':'v':'e':'d':_) -> 'R' : tail what0
-        _                               -> "Changed " ++ what0
+        ('a':what1@('d':'d':'e':'d':_))         -> 'A' : what1
+        ('r':what1@('e':'m':'o':'v':'e':'d':_)) -> 'R' : what1
+        _                                       -> "Changed " ++ what0

src/Distribution/Server/Features/PackageCandidates.hs

@@ -304,12 +304,12 @@ candidatesFeature ServerEnv{serverBlobStore = store}
       where
         cpiToJSON :: [CandPkgInfo] -> Value
         cpiToJSON [] = Null -- should never happen
-        cpiToJSON pkgs = object
+        cpiToJSON pkgs@(pkg:_) = object
             [ Key.fromString "name" .= pn
             , Key.fromString "candidates" .= pvs
             ]
           where
-            pn = T.pack . display . pkgName . candInfoId . head $ pkgs
+            pn = T.pack . display . pkgName . candInfoId $ pkg
             pvs = [ object [ Key.fromString "version" .= (T.pack . display . packageVersion . candInfoId) p
                            , Key.fromString "sha256"  .= (blobInfoHashSHA256 . pkgTarballGz . fst) tarball
                            ]

src/Distribution/Server/Features/ReverseDependencies/State.hs

@@ -1,6 +1,8 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TupleSections #-}
+-- for instance MemSize Dependency
+{-# OPTIONS_GHC -Wno-orphans #-}
 
 module Distribution.Server.Features.ReverseDependencies.State
   ( NodeId

src/Distribution/Server/Features/Security/Migration.hs

@@ -172,8 +172,9 @@ readPrecomputedHashes env@ServerEnv{ serverVerbosity = verbosity } = do
                                                   else throwIO err
 
     parseEntry :: String -> (MD5, (SHA256, Length))
-    parseEntry line = let [md5, sha256, len] = words line
-                      in (md5, (sha256, read len))
+    parseEntry line = case words line of
+                        [md5, sha256, len] -> (md5, (sha256, read len))
+                        _                  -> error $ "Invalid precomputed hash line: " <> show line
 
 {-------------------------------------------------------------------------------
   Migration infrastructure

src/Distribution/Server/Packages/PackageIndex.hs

@@ -69,6 +69,7 @@ import Distribution.Package
 import Distribution.Types.Dependency
 import Distribution.Version ( withinRange )
 import Distribution.Simple.Utils (lowercase)
+import qualified Data.List.NonEmpty as NonEmpty
 
 -- | The collection of information about packages from one or more 'PackageDB's.
 --
@@ -155,9 +156,9 @@ fromList pkgs = mkPackageIndex
   where
     fixBucket = -- out of groups of duplicates, later ones mask earlier ones
                 -- but Map.fromListWith (++) constructs groups in reverse order
-                map head
+                map NonEmpty.head
                 -- Eq instance for PackageIdentifier is wrong, so use Ord:
-              . groupBy (\a b -> EQ == comparing packageId a b)
+              . NonEmpty.groupBy (\a b -> EQ == comparing packageId a b)
                 -- relies on sortBy being a stable sort so we
                 -- can pick consistently among duplicates
               . sortBy (comparing packageId)

src/Distribution/Server/Util/Merge.hs

@@ -1,6 +1,7 @@
 module Distribution.Server.Util.Merge where
 
 import Data.Map
+import qualified Data.Map.Merge.Strict as MapMerge
 
 
 data MergeResult a b = OnlyInLeft a | InBoth a b | OnlyInRight b
@@ -17,4 +18,8 @@ mergeBy cmp = merge
         LT -> OnlyInLeft  x   : merge xs  (y:ys)
 
 mergeMaps :: Ord k => Map k a -> Map k b -> Map k (MergeResult a b)
-mergeMaps m1 m2 = unionWith (\(OnlyInLeft a) (OnlyInRight b) -> InBoth a b) (fmap OnlyInLeft m1) (fmap OnlyInRight m2)
+mergeMaps =
+  MapMerge.merge
+    (MapMerge.mapMissing $ const OnlyInLeft)
+    (MapMerge.mapMissing $ const OnlyInRight)
+    (MapMerge.zipWithMatched $ const InBoth)