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.

diff --git a/Command/MetaData.hs b/Command/MetaData.hs
index e0b86e53023211c64b0e0e2ff2730421d3323942..076fe38bb688f8107cdaf624dc970882dbcc92ad 100644 (file)
--- 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 290b22a9c6d9f858f1dcb75a8d6fbba03ef729f9..c7d4d378cc2513d6c759b740548b8866bcd471ac 100644 (file)
--- 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 2cf103dd9d1217785d288299e464c96cf5097b0a..c60345334000b9fdaf4774b4f83886cf777b7431 100644 (file)
--- 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 ab9a8ca61bb30f745e08d957813f7b416ae6e35b..1b30e9548a54a8ab82246df7274fc8a248a3800e 100644 (file)
--- 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 7561c61261d84814acd0ffa144956fc3839f2783..148e392c72753bd638f17c31791629f6abbb47d5 100644 (file)
--- 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 005a8a89f4ffc29cea7cb9f176a1c656d10f29a3..51c0ebd295bd4e847f5052537910bfbc395415c9 100644 (file)
--- 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"