spaces kinda work

Main.hs

@@ -6,6 +6,7 @@ import Control.Exception
 import Control.Monad
 import Data.Bool
 import Data.Foldable
+import Data.Function
 import Data.List
 import Data.Maybe
 import Data.Traversable
@@ -20,6 +21,8 @@ import System.Process
 import qualified Toks
 import Toks (Tok)
 
+import Debug.Trace
+
 {-
  - interface to other programs
  -}
@@ -127,8 +130,6 @@ hSplitToFile cfg h path =
 {-
  - merge algorithms
  -}
-despace toks = filter (not . Toks.space)
-
 data Op
   = Del
   | Keep
@@ -145,22 +146,79 @@ pdiff path = map go . lines <$> readFile path
 
 data Merged
   = Ok [String]
+  | Replace [String] [String]
   | Conflict [String] [String] [String]
   deriving (Show)
 
-align :: [(Op, String)] -> [(Op, String)] -> [Merged]
+isKeepTok (Keep, _) = True
-align [] [] = []
+isKeepTok _ = False
-align ((Keep, m):ms) ((Keep, y):ys)
+
-  | m == y = Ok [m] : align ms ys
+isDelTok (Del, _) = True
-align ((Del, m):ms) ((Del, y):ys)
+isDelTok _ = False
-  | m == y = Conflict [] [m] [] : align ms ys
+
-align ((Del, m):ms) ((Keep, y):ys)
+chunks :: [(Op, String)] -> [Merged]
-  | m == y = Conflict [] [m] [m] : align ms ys
+chunks [] = []
-align ((Keep, m):ms) ((Del, y):ys)
+chunks xs@((Keep, _):_) =
-  | m == y = Conflict [m] [m] [] : align ms ys
+  let (oks, ys) = span isKeepTok xs
-align ((Add, m):ms) ys = Conflict [m] [] [] : align ms ys
+   in Ok (map snd oks) : chunks ys
-align ms ((Add, y):ys) = Conflict [] [] [y] : align ms ys
+chunks xs =
-align _ _ = error "diffs do not align"
+  let (reps, ys) = break isKeepTok xs
+   in uncurry (Replace `on` map snd) (partition isDelTok reps) : chunks ys
+
+align1 as [] = ([], as, [])
+align1 [] bs = ([], [], bs)
+align1 (a:as) (b:bs)
+  | a == b
+  , (xs, as', bs') <- align1 as bs = (a : xs, as', bs')
+align1 _ _ = error "chunks do not align"
+
+align :: [Merged] -> [Merged] -> [Merged]
+align m y = connect $ slice m y
+  where
+    erase x = Replace x []
+    nemap _ [] = []
+    nemap f xs = [f xs]
+    slice (Ok m:ms) (Ok y:ys) =
+      let (ok, m', y') = align1 m y
+       in (Ok ok, Ok ok) : slice (nemap Ok m' ++ ms) (nemap Ok y' ++ ys)
+    slice (Replace m mr:ms) (Ok y:ys) =
+      let (ok, m', y') = align1 m y
+       in (Replace ok mr, Ok ok)
+            : slice (nemap erase m' ++ ms) (nemap Ok y' ++ ys)
+    slice (Ok m:ms) (Replace y yr:ys) =
+      let (ok, m', y') = align1 m y
+       in (Ok ok, Replace ok yr)
+            : slice (nemap Ok m' ++ ms) (nemap erase y' ++ ys)
+    slice (Replace m mr:ms) (Replace y yr:ys) =
+      let (ok, m', y') = align1 m y
+       in (Replace ok mr, Replace ok yr)
+            : slice (nemap erase m' ++ ms) (nemap erase y' ++ ys)
+    slice [Replace [] mr] [] = [(Replace [] mr, Ok [])]
+    slice [] [Replace [] yr] = [(Ok [], Replace [] yr)]
+    slice [] [] = []
+    slice _ _ = error "unacceptable chunks"
+    coFlag (Ok _) = False
+    coFlag (Replace _ _) = True
+    coSig (a, b) = (coFlag a, coFlag b)
+    coConn' (a, b) (a', b') = (a && a') || (b && b')
+    coConn = coConn' `on` coSig
+    coGroup [] = []
+    coGroup (x:xs) =
+      case coGroup xs of
+        xs'@(ys@(y:_):yss)
+          | coConn x y -> (x : ys) : yss
+        xs' -> [x] : xs'
+    connect = map confl . coGroup
+    toCon (Ok m, Ok _) = Ok m
+    toCon (Ok o, Replace _ y) = Conflict o o y
+    toCon (Replace o m, Ok _) = Conflict m o o
+    toCon (Replace o m, Replace _ y) = Conflict m o y
+    confl = foldr cappend (Ok []) . map toCon
+    cappend (Ok x) (Ok o) = Ok (x ++ o)
+    cappend (Ok x) (Conflict m o y) = error "align consistency check fail" -- Conflict (x++m) (x++o) (x++y)
+    cappend (Conflict m o y) (Ok x) = Conflict (m ++ x) (o ++ x) (y ++ x)
+    cappend (Conflict m o y) (Conflict m' o' y') =
+      Conflict (m ++ m') (o ++ o') (y ++ y')
 
 regroup :: [Merged] -> [Merged]
 regroup [] = []
@@ -169,55 +227,8 @@ regroup (x@(Ok a):xs) =
   case regroup xs of
     (Ok b:xs') -> Ok (a ++ b) : xs'
     xs' -> x : xs'
-regroup (Conflict [] [] []:xs) = regroup xs
-regroup (x@(Conflict m1 o1 y1):xs) =
-  case regroup xs of
-    (Conflict m2 o2 y2:xs') -> Conflict (m1 ++ m2) (o1 ++ o2) (y1 ++ y2) : xs'
-    xs' -> x : xs'
 regroup (x:xs) = x : regroup xs
 
-respace :: Config -> [Tok] -> [Tok] -> [Tok] -> [Merged] -> [Merged]
-respace Config {..} m o y cs = go m o y cs
-  where
-    decide m o y =
-      case cfgSpaces of
-        SpacesConflict -> Conflict m o y
-        SpacesMy -> Ok m
-        SpacesOld -> Ok o
-        SpacesYour -> Ok y
-    go m o y []
-      | all (all Toks.space) [m, o, y] = [decide m o y]
-      | otherwise = error "respace trailed"
-    go m o y (Ok a:cs) =
-      let [(sm, rm), (so, ro), (sy, ry)] = map (re True a) [m, o, y]
-       in decide sm so sy : go rm ro ry cs
-    go m o y (Conflict m' o' y':cs) =
-      let [(sm, rm), (so, ro), (sy, ry)] =
-            zipWith (re False) [m', o', y'] [m, o, y]
-       in Conflict sm so sy : go rm ro ry cs
-    re False [] sp = ([], sp)
-    re True [] sp = break (not . Toks.space) sp
-    re greedy (t:ts) sp =
-      let (sp0, sp') = break (not . Toks.space) sp
-       in case sp' of
-            (s:ss)
-              | s == t ->
-                let (sp1, rest) = re greedy ts ss
-                 in (sp0 ++ s : sp1, rest)
-            [] -> error "respace misaligned"
-
-expand :: Int -> [Merged] -> [Merged]
-expand n = go
-  where
-    go [] = []
-    go (x@(Conflict m1 o1 y1):xs) =
-      case go xs of
-        (Ok a:Conflict m2 o2 y2:xs')
-          | length a <= n ->
-            Conflict (m1 ++ a ++ m2) (o1 ++ a ++ o2) (y1 ++ a ++ y2) : xs'
-        xs' -> x : xs'
-    go (x:xs) = x : go xs
-
 zeal Config {..} (Conflict m o y) =
   before' ++ (Conflict (reverse m'') o (reverse y'') : after')
   where
@@ -242,8 +253,34 @@ zeal Config {..} (Conflict m o y) =
     pops ms ys = ((ms, ys), [])
 zeal _ x = [x]
 
+resolveSpace Config {..} c@(Conflict m o y)
+  | not (all Toks.space $ concat [m, o, y])
+      || cfgSpaces `elem` [SpacesNormal, SpacesConflict] = c
+  | m == o && o == y = Ok o
+  | otherwise =
+    case cfgSpaces of
+      SpacesMy -> Ok m
+      SpacesOld -> Ok o
+      SpacesYour -> Ok y
+      _ -> error $ "spaces resolution error " ++ show cfgSpaces
+resolveSpace _ x = x
+
+expand :: Int -> [Merged] -> [Merged]
+expand n = go
+  where
+    go [] = []
+    go (x@(Conflict m1 o1 y1):xs) =
+      case go xs of
+        (Conflict m2 o2 y2:xs') ->
+          Conflict (m1 ++ m2) (o1 ++ o2) (y1 ++ y2) : xs'
+        (Ok a:Conflict m2 o2 y2:xs')
+          | length a <= n ->
+            Conflict (m1 ++ a ++ m2) (o1 ++ a ++ o2) (y1 ++ a ++ y2) : xs'
+        xs' -> x : xs'
+    go (x:xs) = x : go xs
+
 resolve cfg@Config {..} c@(Conflict m o y)
-  | all Toks.space (concat [m, o, y]) && cfgSpaces /= SpacesNormal =
+  | cfgSpaces /= SpacesNormal && all Toks.space (concat [m, o, y]) =
     resolveSpace cfg c
   | m == o && o == y = Ok o
   | m == o && cfgResolveSeparate = Ok y
@@ -251,39 +288,15 @@ resolve cfg@Config {..} c@(Conflict m o y)
   | m == y && cfgResolveOverlaps = Ok m
 resolve _ x = x
 
--- TODO: there might be a bit of interplay between the spaces handling and
--- separate/overlapped conflict resolution -- e.g., what if someone wants to
--- merge overlapping edits in text but separate edits in spaces? At this point
--- that might be ignorable.
---
--- Also, conflicts that are made out of an ignorable space change and a
--- mergeable non-space change now cause conflicts because the spaces are no
--- longer truly separable/alignable here. Ideally some part of the space
--- merging should be done at alignment (e.g., fake all spaces to cause them to
--- align well). Also it might be necessary to group space-tokens together
--- (newline and indent are now 2 space tokens, which won't ever merge with a
--- single space)
-resolveSpace Config {..} c@(Conflict m o y)
-  | m == o && o == y = Ok o
-  | otherwise =
-    case cfgSpaces of
-      SpacesConflict -> c
-      SpacesMy -> Ok m
-      SpacesOld -> Ok o
-      SpacesYour -> Ok y
-      _ -> error "spaces resolution failed"
-
-resolveSpaces _ x = x
-
--- TODO mix in the despace & respace
 merge cfg@Config {..} ms ys =
   regroup
     . map (resolve cfg)
-    . regroup
-    . bool id (concatMap $ zeal cfg) cfgZealous
     . expand cfgContext
     . regroup
-    $ align ms ys
+    . map (resolveSpace cfg)
+    . bool id (concatMap $ zeal cfg) cfgZealous
+    . regroup
+    $ align (chunks ms) (chunks ys)
 
 {-
  - front-end