patch kinda seems to work

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
+loadToksMM :: TokOpts -> FilePath -> IO TV
-loadToks topt f =
+loadToksMM topt fn = loadToksWith topt fn (mmapFileByteString fn Nothing)
-  V.fromList <$> (mmapFileByteString f Nothing >>= tokenize topt f)
+
+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
+      outFile
-  if patchDryRun o
+        | rewritingInput = patchInput o
-    then do
+        | otherwise = patchOutput o
-      hPutStrLn stderr $
+  traverse_ (note . pprPatchWarn) warns
-        (if sus
+  when dry $
-           then "OK"
+    note $
-           else "Possibly problematic") ++
+    (if not sus
-        " patch with " ++ show (length rej :: Int) ++ " rejected hunks"
+       then "OK"
-      BB.hPutBuilder stdout (pprHunks rej)
+       else "Possibly problematic") ++
-    else do
+    " patch with " ++ show (length rej :: Int) ++ " rejected hunks"
-      when (not $ null rej) $ BB.writeFile rejfile (pprHunks rej)
+  when (not (null rej)) $
-      when (sus && not (null backupfile)) $
+    if dry
-        B.readFile (patchInput o) >>= B.writeFile backupfile
+      then note $ "Would write rejected hunks to " ++ rejFile
-      ($ mconcat $ map (BB.byteString . snd) $ V.toList toks) $
+      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
+          then if dry
-          else BB.writeFile
+                 then note "Would write output to stdout"
-                 (if rewritingInput
+                 else BB.hPutBuilder stdout output
-                    then patchInput o
+          else if dry
-                    else patchOutput o)
+                 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)

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

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 (HunkMatched (offs, _) poffs) =
-pprPatchWarn (HunkFailed ((o,n),_)) = "hunk (-"++ show o ++ " +"++show n++") FAILED"
+  "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])
+pprOffs :: (Int, Int) -> String
-patchToks toks hunks rev mopt = undefined
+pprOffs (o, n) = "-" ++ show o ++ " +" ++ show n
-  --let (tokss, hunk, sus) = patchHunksAt 0 0 0 (if rev then map revHunk hunks else hunks) mopt
-  
 
-patchHunksAt :: TV -> Int -> Int -> Int -> [Hunk] -> MergeOpts -> ([TV], [PatchWarn])
+patchToks ::
-patchHunksAt toks tvoff origoff newoff hunks mopt = undefined
+     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
+patchHunkClean :: PatchState -> Hunk -> MergeOpts -> Maybe PatchState
-hunkToMatch = filter $ (`elem` [Keep, Remove, Original]) . fst
+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
+whitespaceOnly :: Diff -> Bool
-hunkToReplace = filter $ (`elem` [Keep, Add, MineChanged, YourChanged]) . fst
+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