From f85ca7dc80b463d10792905d517809f7e4154b32 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 15 Apr 2020 13:55:08 -0400 Subject: [PATCH] fix all remaining -Wincomplete-uni-patterns warnings A couple of these were probably actual bugs in edge cases. Most of the changes I'm fine with. The fact that aeson's object returns sometihng that we know will be an Object, but the type checker does not know is kind of annoying. --- Command/MetaData.hs | 5 +++-- Config/Cost.hs | 6 +++--- Git/UnionMerge.hs | 16 +++++++++------- Logs/Transfer.hs | 6 +++--- Messages/JSON.hs | 29 +++++++++++++++++++---------- Remote/Bup.hs | 6 ++++-- 6 files changed, 41 insertions(+), 27 deletions(-) diff --git a/Command/MetaData.hs b/Command/MetaData.hs index e0b86e5302..076fe38bb6 100644 --- a/Command/MetaData.hs +++ b/Command/MetaData.hs @@ -119,8 +119,9 @@ perform c o k = case getSet o of cleanup :: Key -> CommandCleanup cleanup k = do m <- getCurrentMetaData k - let Object o = toJSON' (MetaDataFields m) - maybeShowJSON $ AesonObject o + case toJSON' (MetaDataFields m) of + Object o -> maybeShowJSON $ AesonObject o + _ -> noop showLongNote $ unlines $ concatMap showmeta $ map unwrapmeta (fromMetaData m) return True diff --git a/Config/Cost.hs b/Config/Cost.hs index 290b22a9c6..c7d4d378cc 100644 --- a/Config/Cost.hs +++ b/Config/Cost.hs @@ -46,9 +46,9 @@ insertCostAfter [] _ = [] insertCostAfter l pos | pos < 0 = costBetween 0 (l !! 0) : l | nextpos > maxpos = l ++ [1 + l !! maxpos] - | item == nextitem = - let (_dup:new:l') = insertCostAfter lastsegment 0 - in firstsegment ++ [costBetween item new, new] ++ l' + | item == nextitem = case insertCostAfter lastsegment 0 of + (_dup:new:l') -> firstsegment ++ [costBetween item new, new] ++ l' + _ -> error "insertCostAfter internal error" | otherwise = firstsegment ++ [costBetween item nextitem ] ++ lastsegment where diff --git a/Git/UnionMerge.hs b/Git/UnionMerge.hs index 2cf103dd9d..c603453340 100644 --- a/Git/UnionMerge.hs +++ b/Git/UnionMerge.hs @@ -84,14 +84,16 @@ doMerge hashhandle ch differ repo streamer = do - a line suitable for update-index that union merges the two sides of the - diff. -} mergeFile :: S.ByteString -> RawFilePath -> HashObjectHandle -> CatFileHandle -> IO (Maybe L.ByteString) -mergeFile info file hashhandle h = case filter (`notElem` nullShas) [Ref asha, Ref bsha] of - [] -> return Nothing - (sha:[]) -> use sha - shas -> use - =<< either return (hashBlob hashhandle . L8.unlines) - =<< calcMerge . zip shas <$> mapM getcontents shas +mergeFile info file hashhandle h = case S8.words info of + [_colonmode, _bmode, asha, bsha, _status] -> + case filter (`notElem` nullShas) [Ref asha, Ref bsha] of + [] -> return Nothing + (sha:[]) -> use sha + shas -> use + =<< either return (hashBlob hashhandle . L8.unlines) + =<< calcMerge . zip shas <$> mapM getcontents shas + _ -> return Nothing where - [_colonmode, _bmode, asha, bsha, _status] = S8.words info use sha = return $ Just $ updateIndexLine sha TreeFile $ asTopFilePath file -- Get file and split into lines to union merge. diff --git a/Logs/Transfer.hs b/Logs/Transfer.hs index ab9a8ca61b..1b30e9548a 100644 --- a/Logs/Transfer.hs +++ b/Logs/Transfer.hs @@ -143,12 +143,12 @@ getTransfers' dirs wanted = do transfers <- filter (wanted . transferKey) <$> mapMaybe parseTransferFile . concat <$> findfiles infos <- mapM checkTransfer transfers - return $ map (\(t, Just i) -> (t, i)) $ - filter running $ zip transfers infos + return $ mapMaybe running $ zip transfers infos where findfiles = liftIO . mapM dirContentsRecursive =<< mapM (fromRepo . transferDir) dirs - running (_, i) = isJust i + running (t, Just i) = Just (t, i) + running (_, Nothing) = Nothing {- Number of bytes remaining to download from matching downloads that are in - progress. -} diff --git a/Messages/JSON.hs b/Messages/JSON.hs index 7561c61261..148e392c72 100644 --- a/Messages/JSON.hs +++ b/Messages/JSON.hs @@ -65,9 +65,11 @@ none :: JSONBuilder none = id start :: String -> Maybe RawFilePath -> Maybe Key -> JSONBuilder -start command file key _ = Just (o, False) +start command file key _ = case j of + Object o -> Just (o, False) + _ -> Nothing where - Object o = toJSON' $ JSONActionItem + j = toJSON' $ JSONActionItem { itemCommand = Just command , itemKey = key , itemFile = fromRawFilePath <$> file @@ -102,18 +104,22 @@ note s (Just (o, e)) = Just (HM.insertWith combinelines "note" (toJSON' s) o, e) combinelines new _old = new info :: String -> JSONBuilder -info s _ = Just (o, True) +info s _ = case j of + Object o -> Just (o, True) + _ -> Nothing where - Object o = object ["info" .= toJSON' s] + j = object ["info" .= toJSON' s] data JSONChunk v where AesonObject :: Object -> JSONChunk Object JSONChunk :: ToJSON' v => [(String, v)] -> JSONChunk [(String, v)] add :: JSONChunk v -> JSONBuilder -add v (Just (o, e)) = Just (HM.union o' o, e) +add v (Just (o, e)) = case j of + Object o' -> Just (HM.union o' o, e) + _ -> Nothing where - Object o' = case v of + j = case v of AesonObject ao -> Object ao JSONChunk l -> object $ map mkPair l mkPair (s, d) = (packString s, toJSON' d) @@ -125,12 +131,15 @@ complete v _ = add v (Just (HM.empty, True)) -- Show JSON formatted progress, including the current state of the JSON -- object for the action being performed. progress :: Maybe Object -> Maybe Integer -> BytesProcessed -> IO () -progress maction msize bytesprocessed = emit $ case maction of - Just action -> HM.insert "action" (Object action) o - Nothing -> o +progress maction msize bytesprocessed = + case j of + Object o -> emit $ case maction of + Just action -> HM.insert "action" (Object action) o + Nothing -> o + _ -> return () where n = fromBytesProcessed bytesprocessed :: Integer - Object o = case msize of + j = case msize of Just size -> object [ "byte-progress" .= n , "percent-progress" .= showPercentage 2 (percentage size n) diff --git a/Remote/Bup.hs b/Remote/Bup.hs index 005a8a89f4..51c0ebd295 100644 --- a/Remote/Bup.hs +++ b/Remote/Bup.hs @@ -223,8 +223,10 @@ storeBupUUID u buprepo = do giveup "ssh failed" else liftIO $ do r' <- Git.Config.read r - let ConfigValue olduuid = Git.Config.get configkeyUUID mempty r' - when (S.null olduuid) $ + let noolduuid = case Git.Config.get configkeyUUID mempty r' of + ConfigValue olduuid -> S.null olduuid + NoConfigValue -> True + when noolduuid $ Git.Command.run [ Param "config" , Param "annex.uuid"