diff --git a/src/Main.hs b/src/Main.hs index 30d3551..0c7760b 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -42,6 +42,7 @@ data ADiffCommandOpts , patchReject :: String --todo convert to Maybes with optional , patchBackup :: String , patchReverse :: Bool + , patchScanRange :: Int , context :: Int , patchMergeOpts :: MergeOpts , patchInput :: String @@ -69,7 +70,7 @@ contextOpt forPatch = else 8) <> help (if forPatch - then "Minimum amount of context tokens that must match so that the hunk is applied" + then "Maximum number of context tokens that may be discarded from the beginning and end of the hunk when attempting to find a match" else "How many tokens around the change to include in the patch")) where check c @@ -89,7 +90,7 @@ patchCmdOptions = long "dry-run" <> help "Do not patch anything, just print what would happen") <*> -- optional (strOption $ short 'd' <> long "directory" <> metavar "DIR" <> help "Work in DIR") <*> - --option auto (short 'p' <> long "strip" <> metavar "NUM" <> help "Strip NUM leading components from the paths" <> value 0) <*> + -- option auto (short 'p' <> long "strip" <> metavar "NUM" <> help "Strip NUM leading components from the paths" <> value 0) <*> strOption (short 'i' <> long "input" <> @@ -118,6 +119,14 @@ patchCmdOptions = "When rewriting INPUT after a partially applied or otherwise suspicious patch, back up the original file in BACKUP instead of default `INPUT.orig'. Use `-' to discard backups." <> value "") <*> switch (short 'R' <> long "reverse" <> help "Unapply applied patches") <*> + option + auto + (short 'S' <> + long "scan-range" <> + metavar "RANGE" <> + help + "Maximum distance from the indended patch position (in tokens) for fuzzy matching of hunks" <> + value 42) <*> contextOpt True <*> mergeOption True <*> strArgument (metavar "INPUT") @@ -143,13 +152,18 @@ adiffOptions :: Parser ADiffOptions adiffOptions = ADiffOptions <$> tokOptions <*> actionOptions -- TODO: load in case it's not a regular file -loadToks :: TokOpts -> FilePath -> IO TV -loadToks topt f = - V.fromList <$> (mmapFileByteString f Nothing >>= tokenize topt f) +loadToksMM :: TokOpts -> FilePath -> IO TV +loadToksMM topt fn = loadToksWith topt fn (mmapFileByteString fn Nothing) + +loadToksR :: TokOpts -> FilePath -> IO TV +loadToksR topt fn = loadToksWith topt fn (B.readFile fn) + +loadToksWith :: TokOpts -> FilePath -> IO BS -> IO TV +loadToksWith topt fn bs = V.fromList <$> (bs >>= tokenize topt fn) doDiff :: TokOpts -> ADiffCommandOpts -> IO () doDiff topt (CmdDiff {diffFile1 = f1, diffFile2 = f2, context = ctxt}) = do - [toks1, toks2] <- traverse (loadToks topt) [f1, f2] + [toks1, toks2] <- traverse (loadToksMM topt) [f1, f2] let output = hunks (max 0 ctxt) $ diffToks toks1 toks2 BB.hPutBuilder stdout $ pprHunks output unless (null output) $ exitWith (ExitFailure 1) @@ -157,7 +171,7 @@ doDiff _ _ = error "dispatch failure" doDiff3 :: TokOpts -> ADiffCommandOpts -> IO () doDiff3 topt (CmdDiff3 ctxt f1 f2 f3 mo) = do - [toksMine, toksOld, toksYour] <- traverse (loadToks topt) [f1, f2, f3] + [toksMine, toksOld, toksYour] <- traverse (loadToksMM topt) [f1, f2, f3] let d3 = diff3Toks mo toksMine toksOld toksYour isConflict (MineChanged, _) = True isConflict (YourChanged, _) = True @@ -171,9 +185,12 @@ doDiff3 topt (CmdDiff3 ctxt f1 f2 f3 mo) = do when hasConflict $ exitWith (ExitFailure 1) doDiff3 _ _ = error "dispatch failure" +note :: String -> IO () +note = hPutStrLn stderr + doPatch :: TokOpts -> ADiffCommandOpts -> IO () doPatch topt o = do - toksIn <- loadToks topt (patchInput o) + toksIn <- loadToksR topt (patchInput o) hs' <- parsePatch <$> case (patchInputPatch o) of @@ -184,37 +201,60 @@ doPatch topt o = do Left _ -> ioError $ userError "PATCHFILE parsing failed" Right x -> pure x let (toks, rej, warns) = - patchToks toksIn hs (patchReverse o) (patchMergeOpts o) + patchToks + toksIn + hs + (patchReverse o) + (patchScanRange o) + (context o) + (patchMergeOpts o) sus = not (null warns) + dry = patchDryRun o rewritingInput = null (patchOutput o) outputStdout = patchOutput o == "-" - rejfile + rejFile | rewritingInput || outputStdout = patchInput o ++ ".rej" | otherwise = patchOutput o ++ ".rej" - backupfile + backupFile | patchBackup o == "-" = "" | patchBackup o == "" && rewritingInput = patchInput o ++ ".orig" | otherwise = patchBackup o - traverse_ (hPutStrLn stderr . pprPatchWarn) warns - if patchDryRun o - then do - hPutStrLn stderr $ - (if sus - then "OK" - else "Possibly problematic") ++ - " patch with " ++ show (length rej :: Int) ++ " rejected hunks" - BB.hPutBuilder stdout (pprHunks rej) - else do - when (not $ null rej) $ BB.writeFile rejfile (pprHunks rej) - when (sus && not (null backupfile)) $ - B.readFile (patchInput o) >>= B.writeFile backupfile - ($ mconcat $ map (BB.byteString . snd) $ V.toList toks) $ + outFile + | rewritingInput = patchInput o + | otherwise = patchOutput o + traverse_ (note . pprPatchWarn) warns + when dry $ + note $ + (if not sus + then "OK" + else "Possibly problematic") ++ + " patch with " ++ show (length rej :: Int) ++ " rejected hunks" + when (not (null rej)) $ + if dry + then note $ "Would write rejected hunks to " ++ rejFile + else do + note $ "Writing rejected hunks to " ++ rejFile + BB.writeFile rejFile (pprHunks rej) + when (sus && not (null backupFile)) $ + if dry + then note $ "Would write backup to " ++ backupFile + else do + note $ "Writing backup to " ++ backupFile + B.readFile (patchInput o) >>= B.writeFile backupFile + let doWrite output = if outputStdout - then BB.hPutBuilder stdout - else BB.writeFile - (if rewritingInput - then patchInput o - else patchOutput o) + then if dry + then note "Would write output to stdout" + else BB.hPutBuilder stdout output + else if dry + then note $ "Would write output to " ++ outFile + else do + note $ "Writing output to " ++ outFile + BB.writeFile outFile output + doWrite (mconcat . map (BB.byteString . snd) . V.toList $ toks) + when (dry && not (null rej)) $ do + note "Rejected hunks:" + BB.hPutBuilder stdout (pprHunks rej) when sus $ exitWith (ExitFailure 1) main' :: IO () @@ -241,5 +281,5 @@ main = main' `catch` (\e -> do let err = show (e :: IOException) - hPutStrLn stderr err + note err exitWith $ ExitFailure 2) diff --git a/src/Merge.hs b/src/Merge.hs index b56a70d..8f17488 100644 --- a/src/Merge.hs +++ b/src/Merge.hs @@ -47,7 +47,7 @@ mergeOption forPatch = then "Instead of printing the rejected thunks, merge using conflict markers as if the INPUT was `MYFILE' and the patch would produced `YOURFILE' from the original." else "Output the merged file instead of the patch")) <*> switch - (short 'i' <> + (short 'I' <> long "ignore-whitespace" <> help ("Ignore " ++ @@ -56,7 +56,7 @@ mergeOption forPatch = else "chunks") ++ " that change only whitespace")) <*> switch - (short 'f' <> + (short 'F' <> long "force-whitespace" <> help ((if forPatch @@ -64,7 +64,7 @@ mergeOption forPatch = else "Force a merge conflict") ++ " on whitespace mismatch (overrides `ignore-whitespace')")) <*> switch - (short 'k' <> + (short 'K' <> long "keep-whitespace" <> help ("On whitespace mismatch, output the version from " ++ diff --git a/src/Patch.hs b/src/Patch.hs index b1b62e2..e1b187a 100644 --- a/src/Patch.hs +++ b/src/Patch.hs @@ -1,30 +1,171 @@ -module Patch (patchToks, pprPatchWarn) where +module Patch + ( patchToks + , pprPatchWarn + ) where -import Format -import Types -import Merge import qualified Data.ByteString as B +import Data.Maybe (catMaybes) +import qualified Data.Vector as V +import Format +import Merge +import Types -data PatchWarn = HunkMatched Hunk Int | HunkFailed Hunk +data PatchWarn + = HunkMatched Hunk (Int, Int) + | HunkFailed Hunk (Int, Int) + deriving (Show) + +data PatchOpts = + PatchOpts + { scanRange :: Int + , minContext :: Int + , mergeOpts :: MergeOpts + } + +data PatchState = + PatchState + { input :: TV + , output :: [TV] + , warns :: [PatchWarn] + , inOff :: Int -- where we are in `input` + , patchInOff :: Int -- to what position does that correspond in patch input (gets adjusted on fuzzy matches) + , outOff :: Int -- where we are in output tokens (informative) + , patchOutOff :: Int -- to what position does that correspond in patch output (gets adjusted from processed hunks) + } pprPatchWarn :: PatchWarn -> String -pprPatchWarn (HunkMatched ((o,n), _) at) = "hunk (-"++ show o ++ " +"++show n++") succeeded at "++show at -pprPatchWarn (HunkFailed ((o,n),_)) = "hunk (-"++ show o ++ " +"++show n++") FAILED" +pprPatchWarn (HunkMatched (offs, _) poffs) = + "hunk (" ++ pprOffs offs ++ ") succeeded at " ++ pprOffs poffs +pprPatchWarn (HunkFailed (offs, _) poffs) = + "hunk (" ++ pprOffs offs ++ ") FAILED, expected at " ++ pprOffs poffs -patchToks :: TV -> [Hunk] -> Bool -> MergeOpts -> (TV, [Hunk], [PatchWarn]) -patchToks toks hunks rev mopt = undefined - --let (tokss, hunk, sus) = patchHunksAt 0 0 0 (if rev then map revHunk hunks else hunks) mopt - +pprOffs :: (Int, Int) -> String +pprOffs (o, n) = "-" ++ show o ++ " +" ++ show n -patchHunksAt :: TV -> Int -> Int -> Int -> [Hunk] -> MergeOpts -> ([TV], [PatchWarn]) -patchHunksAt toks tvoff origoff newoff hunks mopt = undefined +patchToks :: + TV + -> [Hunk] + -> Bool + -> Int + -> Int + -> MergeOpts + -> (TV, [Hunk], [PatchWarn]) +patchToks toks hunks revPatch scan ctxt mopt = + go hunks $ PatchState toks [] [] 0 0 0 0 + where + go [] ps = + ( V.concat (output ps ++ [V.drop (inOff ps) (input ps)]) + , [rej | HunkFailed rej _ <- warns ps] + , warns ps) + go (h:hs) ps = go hs ps' + where + ((fromPos, toPos), diff) = h + advance = fromPos - patchInOff ps + noMatch = + ps + { warns = + warns ps ++ + [HunkFailed h (advance + inOff ps, advance + outOff ps)] + , patchOutOff = patchOutOff ps - diffOffChange diff + } + cleanMatch :: Maybe PatchState + cleanMatch = patchHunkClean ps h mopt + isContext :: (Op, Tok) -> Bool + isContext (op, _) = op == Keep + discardedContextDiffs :: [(Int, Diff)] + discardedContextDiffs = + let (fwdCtxt, d') = span isContext diff + (revCtxt, revMid) = span isContext (reverse d') + mid = reverse revMid + discards n c@(_:r) = (n, c) : discards (n + 1) r + discards n [] = (n, []) : discards n [] + in zipWith + (\(dfwd, fwd) (drev, rev) -> + (max dfwd drev, fwd ++ mid ++ reverse rev)) + (discards 0 fwdCtxt) + (discards 0 revCtxt) + fuzzyHunks :: [Hunk] + fuzzyHunks = do + (discarded, ddiff) <- take (ctxt + 1) discardedContextDiffs + off <- 0 : concatMap (\x -> [-x, x]) [1 .. scan] + pure ((fromPos + discarded + off, toPos + discarded), ddiff) + fuzzyMatches = + [ (\x -> x {warns = warns x ++ [HunkMatched h fPos]}) <$> + patchHunkClean ps fh mopt + | fh@(fPos, _) <- tail fuzzyHunks -- tail omits the "clean" 0,0 one + ] + ps' = head $ catMaybes (cleanMatch : fuzzyMatches) ++ [noMatch] -hunkToMatch :: Diff -> Diff -hunkToMatch = filter $ (`elem` [Keep, Remove, Original]) . fst +patchHunkClean :: PatchState -> Hunk -> MergeOpts -> Maybe PatchState +patchHunkClean ps ((fromPos, toPos), diff) mopts + | expInOff < 0 || expOutOff < 0 = Nothing + | mergeIgnoreWhitespace mopts && whitespaceOnly diff = Just ps + | Just repl <- matchDiff mopts (V.toList origPart) diff = + Just + ps + { output = output ps ++ [skipped, V.fromList repl] + , inOff = expInOff + matchLen + , patchInOff = fromPos + matchLen + , outOff = expOutOff + length repl + , patchOutOff = toPos + length repl + } + | otherwise = Nothing + where + matchLen = diffMatchLen diff + advance = fromPos - patchInOff ps + expInOff = advance + inOff ps + expOutOff = advance + outOff ps + skipped = V.take expInOff $ input ps + origPart = V.take matchLen $ V.drop expInOff $ input ps -hunkToReplace :: Diff -> Diff -hunkToReplace = filter $ (`elem` [Keep, Add, MineChanged, YourChanged]) . fst +whitespaceOnly :: Diff -> Bool +whitespaceOnly = all wsOnly + where + wsOnly (Keep, _) = True + wsOnly (Original, _) = True + wsOnly (_, (False, _)) = True + wsOnly _ = False + +diffMatchLen :: Diff -> Int +diffMatchLen = sum . map (off . fst) + where + off Keep = 1 + off Remove = 1 + off Original = 1 + off _ = 0 + +diffOffChange :: Diff -> Int +diffOffChange = sum . map (off . fst) + where + off Add = 1 + off Remove = -1 + off _ = 0 + +matchDiff :: MergeOpts -> [Tok] -> Diff -> Maybe [Tok] +matchDiff mopt ts ds + | null ts + , null ds = return [] + | ((op, tok):ds') <- ds + , op == Add {-, MineChanged, YourChanged -- TODO special treatment needed -} + = (tok :) <$> matchDiff mopt ts ds' + | (intok:ts') <- ts + , ((op, tok):ds') <- ds + , op == Keep {-, Original -- TODO special treatment needed-} + , tokCmp' mopt intok tok = + (:) + (if mergeKeepWhitespace mopt && not (fst intok) + then intok + else tok) <$> + matchDiff mopt ts' ds' + | (intok:ts') <- ts + , ((op, tok):ds') <- ds + , op == Remove + , tokCmp' mopt intok tok = matchDiff mopt ts' ds' + | otherwise = Nothing + +tokCmp' :: MergeOpts -> Tok -> Tok -> Bool +tokCmp' MergeOpts {mergeForceWhitespace = x} = tokCmp x tokCmp :: Bool -> Tok -> Tok -> Bool -tokCmp True (False, _) (False, _) = True -- ignore the whitespace change +tokCmp False (False, _) (False, _) = True -- do not force rejecting on whitespace change tokCmp _ a b = a == b -- otherwise just compare