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.
This commit is contained in:
parent
43a9808292
commit
f85ca7dc80
6 changed files with 41 additions and 27 deletions
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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.
|
||||
|
|
|
@ -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. -}
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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"
|
||||
|
|
Loading…
Add table
Reference in a new issue