patch kinda seems to work

2022-05-29 14:27:01 +02:00 · 2022-05-29 14:27:01 +02:00 · c4c37405e9
parent 6e2ab88961
commit c4c37405e9
3 changed files with 233 additions and 52 deletions
--- 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)
--- 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 " ++
--- 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

+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]

-patchHunksAt :: TV -> Int -> Int -> Int -> [Hunk] -> MergeOpts -> ([TV], [PatchWarn])
-patchHunksAt toks tvoff origoff newoff hunks mopt = undefined
+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

-hunkToMatch :: Diff -> Diff
-hunkToMatch = filter $ (`elem` [Keep, Remove, Original]) . fst
+whitespaceOnly :: Diff -> Bool
+whitespaceOnly = all wsOnly
+  where
+    wsOnly (Keep, _) = True
+    wsOnly (Original, _) = True
+    wsOnly (_, (False, _)) = True
+    wsOnly _ = False

-hunkToReplace :: Diff -> Diff
-hunkToReplace = filter $ (`elem` [Keep, Add, MineChanged, YourChanged]) . fst
+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