app/Rehi.hs

   1 {-# LANGUAGE FlexibleContexts #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   3 {-# LANGUAGE PartialTypeSignatures #-}
   4 {-# LANGUAGE PackageImports #-}
   5 {-# LANGUAGE LambdaCase #-}
   6 {-# LANGUAGE MultiWayIf #-}
   7 {-# LANGUAGE PatternSynonyms #-}
   8 {-# LANGUAGE ScopedTypeVariables #-}
   9 {-# LANGUAGE TupleSections #-}
  10 {-# LANGUAGE ViewPatterns #-}
  11 {-# OPTIONS_GHC -Wall #-}
  12 {-# OPTIONS_GHC -fno-warn-partial-type-signatures #-}
  13 {-# OPTIONS_GHC -fno-warn-missing-signatures #-}
  14 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
  15 {-# OPTIONS_GHC -fno-warn-unused-imports #-}
  16 {-# OPTIONS_GHC -fno-warn-unused-matches #-}
  17 {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
  18 module Rehi where
  19
  20 import Prelude hiding (putStrLn,putStr,writeFile,readFile)
  21
  22 import Data.ByteString(ByteString,uncons)
  23 import Data.ByteString.Char8(putStrLn,putStr,pack,hPutStrLn)
  24 import Data.List(foldl')
  25 import Data.Maybe(fromMaybe,isJust,isNothing)
  26 import Data.Monoid((<>))
  27 import Control.Monad(foldM,forM_,when)
  28 import Control.Monad.Catch(MonadMask,finally,catch,SomeException,throwM,Exception)
  29 import Control.Monad.Fix(fix)
  30 import Control.Monad.IO.Class(liftIO,MonadIO)
  31 import Control.Monad.Reader(MonadReader,ask)
  32 import Control.Monad.RWS(execRWST, RWST, runRWST)
  33 import Control.Monad.State(put,get,modify',MonadState)
  34 import Control.Monad.Trans(lift)
  35 import Control.Monad.Trans.Reader(ReaderT(runReaderT))
  36 import Control.Monad.Trans.State(evalStateT,execStateT)
  37 import Control.Monad.Trans.Cont(ContT(ContT),evalContT)
  38 import Control.Monad.Trans.Writer(execWriterT)
  39 import Control.Monad.Writer(tell)
  40 import System.Exit (ExitCode(ExitSuccess))
  41 import System.IO(hClose,IOMode(WriteMode,AppendMode),hSetBinaryMode)
  42
  43 import qualified Data.ByteString as ByteString
  44 import qualified Data.ByteString.Char8 as BC
  45 import qualified Data.Map.Strict as Map
  46 import qualified Data.Set as Set
  47 import qualified Prelude as Prelude
  48
  49 import Rehi.IO(withBinaryFile,readBinaryFile,openBinaryFile,openBinaryTempFile,createDirectory,removeDirectoryRecursive,
  50           removeFile,doesFileExist,doesDirectoryExist, getArgs,lookupEnv, system, initEncoding)
  51 import Rehi.Utils (equalWith, index_only, run_command, readPopen, mapCmdLinesM, mapFileLinesM, modifySnd,
  52                    trim, writeFile, appendToFile, whenM, unlessM, ifM, command_lines)
  53 import Rehi.Regex (regex_match, regex_match_with_newlines, regex_match_all, regex_split)
  54 import Rehi.GitTypes (Hash(Hash), hashString)
  55
  56 import qualified Rehi.GitCommands as Cmd
  57
  58 main :: IO ()
  59 main = do
  60   initEncoding
  61   env <- get_env
  62   flip runReaderT env $ do
  63     args <- liftIO getArgs
  64     let parsed = parse_cli args
  65     case parsed of
  66       Abort -> abort_rebase
  67       Continue -> do
  68         (todo, current, commits, target_ref, marks) <- restore_rebase
  69         case current of
  70           Just c -> do
  71             run_continue c commits
  72             liftIO (removeFile (envGitDir env `mappend` "/rehi/current"))
  73           Nothing -> return ()
  74         lift $ run_rebase (envGitDir env) todo commits target_ref marks Sync
  75       Skip -> do
  76         (todo, current, commits, target_ref, marks) <- restore_rebase
  77         case current of
  78           Just c -> do
  79             liftIO $ Cmd.reset $ "HEAD"
  80             liftIO (removeFile (envGitDir env `mappend` "/rehi/current"))
  81         lift $ run_rebase (envGitDir env) todo commits target_ref marks Sync
  82       Current -> do
  83         let currentPath = envGitDir env `mappend` "/rehi/current"
  84         liftIO (doesFileExist currentPath) `unlessM` error "No rehi in progress"
  85         content <- liftIO $ readBinaryFile currentPath
  86         liftIO $ putStr ("Current: " <> content <> (if ByteString.null content || BC.last content /= '\n' then "\n" else ""))
  87       Run dest source_from_arg through source_to_arg target_arg interactive -> do
  88         git_verify_clean
  89         initial_branch <- git_get_checkedout_branch
  90         let
  91           target_ref = fromMaybe initial_branch target_arg
  92           source_to = fromMaybe target_ref source_to_arg
  93         source_from <- case source_from_arg of
  94           Just s -> pure s
  95           Nothing | Just _ <- regex_match dest ".*~1$" -> pure dest
  96           Nothing -> git_merge_base source_to dest
  97         let
  98           through' = case regex_match source_from "^(.*)~1$" of
  99             Just (_ : m : _) -> m : through
 100             Nothing -> through
 101         main_run dest source_from through' source_to target_ref initial_branch interactive
 102
 103 data CliMode =
 104   Abort
 105   | Continue
 106   | Skip
 107   | Current
 108   | Run { runDest :: ByteString
 109         , runFrom :: (Maybe ByteString)
 110         , runThroughs :: [ByteString]
 111         , runTo :: (Maybe ByteString)
 112         , runTarget :: (Maybe ByteString)
 113         , runInteractive :: Bool }
 114   deriving (Show, Eq)
 115
 116 data Head = Sync | Known Hash deriving Show
 117
 118 data Commits = Commits {
 119     commitsRefs :: Map.Map ByteString Hash
 120   , commitsByHash :: Map.Map Hash Entry
 121   } deriving Show
 122
 123 data Entry = Entry {
 124     entryAHash :: ByteString
 125   , entryHash :: Hash
 126   , entrySubject :: ByteString
 127   , entryParents :: [Hash]
 128   , entryTree :: Hash
 129   , entryBody :: ByteString
 130   } deriving Show
 131
 132 data Step =
 133     Pick ByteString
 134   | Fixup ByteString
 135   | Edit ByteString
 136   | Exec ByteString
 137   | Comment ByteString
 138   | Merge { mergeRef :: Maybe ByteString, mergeParents :: [ByteString], mergeOurs :: Bool, mergeNoff :: Bool }
 139   | Mark ByteString
 140   | Reset ByteString
 141   | UserComment ByteString
 142   | TailPickWithComment ByteString ByteString
 143   deriving (Show, Eq)
 144
 145 data Env a = Env { envGitDir :: ByteString, envRest :: a }
 146
 147 -- Tmp State
 148 data TS = TS {
 149     tsHead :: Head
 150   , tsMarks :: Map.Map ByteString Hash
 151 }
 152
 153 -- Tmp Env
 154 type TE = Env Commits
 155
 156 teGitDir = envGitDir
 157
 158 teRefs = commitsRefs . envRest
 159
 160 teByHash = commitsByHash . envRest
 161
 162 pattern TE refs byHash <- Env { envRest = (Commits refs byHash) }
 163
 164 data StepResult = StepPause | StepNext
 165
 166 newtype EditError = EditError ByteString deriving Show
 167
 168 instance Exception EditError
 169
 170 parse_cli = parse_loop False
 171   where
 172     parse_loop _ ("-i" : argv') = parse_loop True argv'
 173     parse_loop _ ("--interactive" : argv') = parse_loop True argv'
 174     parse_loop _ argv@("--abort" : _ : _ ) = error ("Extra argument:" ++ show argv)
 175     parse_loop _ ["--abort"] = Abort
 176     parse_loop _ argv@("--continue" : _ : _ ) = error ("Extra argument:" ++ show argv)
 177     parse_loop _ ["--continue"] = Continue
 178     parse_loop _ argv@("--skip" : _ : _ ) = error ("Extra argument:" ++ show argv)
 179     parse_loop _ ["--skip"] = Skip
 180     parse_loop _ argv@("--current" : _ : _ ) = error ("Extra argument:" ++ show argv)
 181     parse_loop _ ["--current"] = Current
 182     parse_loop interactive [dest] = Run dest Nothing [] Nothing Nothing interactive
 183     parse_loop interactive (arg0 : arg1 : arg2mb) | length arg2mb == 1 || length arg2mb == 0 && isJust (regex_match arg1 "\\.\\.") =
 184         let
 185           re_ref0 = "(?:[^\\.]|(?<!\\.)\\.)*"
 186           re_ref1 = "(?:[^\\.]|(?<!\\.)\\.)+"
 187           re_sep = "(?<!\\.)\\.\\."
 188           (source_from, through, source_to) = case regex_match arg1 (mconcat ["^(", re_ref0, ")", re_sep, "((?:", re_ref1, re_sep, ")*)(", re_ref0, ")$"]) of
 189             Just [all, m1, m2, m3] -> (m1, regex_match_all m2 (mconcat ["(", re_ref1, ")", re_sep]), m3)
 190             _ -> error ("Invalid source spec:" ++ show arg1)
 191           arg2 = case arg2mb of
 192             [] -> Nothing
 193             [v] -> Just v
 194           maybeFromString "" = Nothing
 195           maybeFromString s = Just s
 196         in Run arg0 (maybeFromString source_from) through (maybeFromString source_to) arg2 interactive
 197     parse_loop interactive [arg0, arg1] = Run arg0 Nothing [] Nothing (Just arg1) interactive
 198     parse_loop _ argv = error ("Invalid arguments: " ++ show argv)
 199
 200 main_run :: ByteString -> ByteString -> [ByteString] -> ByteString -> ByteString -> ByteString -> Bool -> ReaderT (Env ()) IO ()
 201 main_run dest source_from through source_to target_ref initial_branch interactive = do
 202   (todo, commits, dest_hash) <- init_rebase dest source_from through source_to target_ref initial_branch
 203   (todo, commits) <- if interactive
 204     then (do
 205       let todo' = add_info_to_todo todo commits
 206       edit_todo todo' commits >>= \case
 207         Just todo -> pure (todo, commits)
 208         Nothing -> do
 209           cleanup_save
 210           fail "Aborted")
 211     else pure (todo, commits)
 212   if any (\case { UserComment _ -> False ; _ -> True }) todo
 213     then (do
 214       gitDir <- askGitDir
 215       liftIO $ save_todo todo (gitDir <> "/rehi/todo.backup") commits
 216       liftIO $ Cmd.checkout_detached $ hashString dest_hash
 217       lift $ run_rebase gitDir todo commits target_ref Map.empty (Known dest_hash))
 218     else (do
 219         liftIO(putStrLn "Nothing to do")
 220         cleanup_save)
 221
 222 restore_rebase = do
 223   gitDir <- askGitDir
 224   target_ref <- liftIO (readBinaryFile (gitDir <> "/rehi/target_ref"))
 225   (commits, marks) <- git_load_commits
 226   todo <- read_todo (gitDir <> "/rehi/todo") commits
 227   current <- ifM (liftIO (doesFileExist (gitDir <> "/rehi/current")))
 228                 (do
 229                   [step] <- read_todo (gitDir <> "/rehi/current") commits
 230                   pure (Just step))
 231                 (pure Nothing)
 232   pure (todo, current, commits, target_ref, marks)
 233
 234 init_rebase :: _ -> _ -> _ -> _ -> _ -> _ -> ReaderT (Env a) IO ([_], _, _)
 235 init_rebase dest source_from through source_to target_ref initial_branch = do
 236   (dest_hash : source_from_hash : source_to_hash : through_hashes ) <-
 237     liftIO $ Cmd.git_resolve_hashes (dest : source_from : source_to : through)
 238   init_save target_ref initial_branch
 239   commits <- git_fetch_cli_commits source_from source_to
 240   let unknown_parents = find_unknown_parents commits
 241   commits <- git_fetch_commit_list commits unknown_parents
 242   let todo = build_rebase_sequence commits source_from_hash source_to_hash through_hashes
 243   pure (todo, commits, dest_hash)
 244
 245 find_unknown_parents commits =
 246   Set.toList $ Set.fromList [ p | c <- Map.elems (commitsByHash commits),
 247                                   p <- entryParents c,
 248                                   not (Map.member p (commitsByHash commits)) ]
 249
 250 help = "Commands:\n\
 251        \\n\
 252        \ pick\n\
 253        \ fixup\n\
 254        \ edit\n\
 255        \ exec\n\
 256        \ comment\n\
 257        \ merge\n\
 258        \ :\n\
 259        \ reset\n\
 260        \ end\n"
 261
 262 comments_from_string :: ByteString -> Int -> [Step]
 263 comments_from_string content indent =
 264   map (\l -> UserComment (mconcat (replicate indent " ") <> l))
 265       (regex_split content "\\r\\n|\\r|\\n")
 266
 267 add_info_to_todo old_todo commits = old_todo ++ comments_from_string help 0 ++ [UserComment "", UserComment " Commits"] ++ comments
 268   where
 269     comments = concatMap (\case
 270       Pick ah -> from_hash ah
 271       Fixup ah -> from_hash ah
 272       Edit ah -> from_hash ah
 273       Merge (Just ah) _ _ _ -> from_hash ah
 274       _ -> []) old_todo
 275     from_hash ah = fromMaybe [] (do
 276       h <- Map.lookup ah (commitsRefs commits)
 277       e <- Map.lookup h (commitsByHash commits)
 278       pure ([UserComment ("----- " <> ah <> " -----")] ++ comments_from_string (entryBody e) 0))
 279
 280 edit_todo old_todo commits = do
 281   gitDir <- askGitDir
 282   (todoPath, todoHandle) <- liftIO (openBinaryTempFile (gitDir <> "/rehi") "todo.XXXXXXXX")
 283   liftIO (hClose todoHandle)
 284   liftIO $ save_todo old_todo todoPath commits
 285   retry (do
 286     -- use git to launch editor to avoid dealing with msys paths in Windows
 287     liftIO (run_command ("git config --edit --file \"" <> todoPath <> "\""))
 288     todo_rc <- read_todo todoPath commits
 289     verify_marks todo_rc
 290     pure todo_rc)
 291
 292 verify_marks todo = do
 293     _ <- foldM (\marks -> \case
 294                       Mark m | Set.member m marks -> throwM (EditError ("Duplicated mark: " <> m))
 295                       Mark m -> pure $ Set.insert m marks
 296                       Pick ref -> check marks ref
 297                       Fixup ref -> check marks ref
 298                       Edit ref -> check marks ref
 299                       Reset ref -> check marks ref
 300                       Merge _ refs _ _ -> mapM_ (check marks) refs >> pure marks
 301                       UserComment _ -> pure marks
 302                       TailPickWithComment _ _ -> pure marks
 303                       Comment _ -> pure marks
 304                       Exec _ -> pure marks) Set.empty todo
 305     pure ()
 306   where
 307     check marks (uncons -> Just ((== (ByteString.head "@")) -> True, mark)) | not (Set.member mark marks) = throwM (EditError ("Unknown mark:" <> mark))
 308     check marks _ = pure marks
 309
 310 run_continue :: (MonadReader (Env a) m, MonadIO m) => Step -> t -> m ()
 311 run_continue current commits = do
 312   liftIO $ Cmd.verify_clean
 313   case current of
 314     Pick ah -> git_no_uncommitted_changes `unlessM` liftIO (Cmd.commit $ Just ah)
 315     Merge ahM _ _ _ -> git_no_uncommitted_changes `unlessM` liftIO (Cmd.commit ahM)
 316     Edit _ -> git_no_uncommitted_changes `unlessM` fail "No unstaged changes should be after 'edit'"
 317     Fixup _ -> git_no_uncommitted_changes `unlessM` liftIO Cmd.commit_amend
 318     Exec cmd -> fail ("Cannot continue '" ++ show cmd ++ "'; resolve it manually, then skip or abort")
 319     Comment c -> comment c
 320     _ -> fail ("run_continue: Unexpected " ++ show current)
 321
 322 data FinalizeMode = CleanupData | KeepData
 323
 324 run_rebase gitDir todo commits target_ref marks curHead =
 325     evalStateT
 326       (runReaderT doJob (Env gitDir commits))
 327       (TS curHead marks)
 328   where
 329     doJob = do
 330       result <- mainLoop
 331       release
 332       case result of
 333         CleanupData -> do
 334           liftIO $ Cmd.checkout_here target_ref
 335           cleanup_save
 336         KeepData -> pure ()
 337     release = do
 338       (catch :: _ -> (SomeException -> _) -> _)
 339         sync_head
 340         (\e -> do
 341           liftIO $ Prelude.putStrLn ("Fatal error: " <> show e)
 342           liftIO $ putStrLn "Not possible to continue"
 343           liftIO $ removeFile (gitDir <> "/rehi/todo"))
 344     mainLoop = fix (\rec todo -> do
 345                             case todo of
 346                               (current : todo) -> do
 347                                 let hasIo = case current of
 348                                               UserComment _ -> False
 349                                               TailPickWithComment _ _ -> False
 350                                               _ -> True
 351                                 when hasIo (do
 352                                   commits <- envRest <$> ask
 353                                   liftIO $ save_todo todo (gitDir <> "/rehi/todo") commits
 354                                   liftIO $ save_todo [current] (gitDir <> "/rehi/current") commits)
 355                                 run_step current >>= \case
 356                                   StepPause -> pure KeepData
 357                                   StepNext -> do
 358                                     when hasIo $ liftIO (removeFile (gitDir <> "/rehi/current"))
 359                                     rec todo
 360                               [] -> pure CleanupData) todo
 361
 362 abort_rebase = do
 363   gitDir <- askGitDir
 364   initial_branch <- liftIO $ readBinaryFile (gitDir <> "/rehi/initial_branch")
 365   liftIO $ Cmd.reset initial_branch
 366   liftIO $ Cmd.checkout_force initial_branch
 367   cleanup_save
 368
 369 run_step
 370   :: (MonadIO m,
 371       MonadReader TE m,
 372       MonadState TS m) =>
 373      Step -> m StepResult
 374 run_step rebase_step = do
 375   evalContT $ do
 376     case rebase_step of
 377       Pick ah -> do
 378         pick =<< resolve_ahash ah
 379       Edit ah -> do
 380         commits <- envRest <$> ask
 381         liftIO $ putStrLn ("Apply: " <> commits_get_subject commits ah)
 382         pick =<< resolve_ahash ah
 383         sync_head
 384         liftIO $ Prelude.putStrLn "Amend the commit and run \"git rehi --continue\""
 385         returnC $ pure StepPause
 386       Fixup ah -> do
 387         commits <- envRest <$> ask
 388         liftIO $ putStrLn ("Fixup: " <> commits_get_subject commits ah)
 389         sync_head
 390         (liftIO . Cmd.fixup) =<< resolve_ahash ah
 391       Reset ah -> do
 392         hash_or_ref <- resolve_ahash ah
 393         fmap (Map.member (Hash hash_or_ref) . teByHash) ask >>= \case
 394           True -> modify' (\ts -> ts { tsHead = Known $ Hash hash_or_ref})
 395           False -> do
 396             liftIO $ Cmd.reset hash_or_ref
 397             modify' (\ts -> ts{tsHead = Sync})
 398       Exec cmd -> do
 399         sync_head
 400         liftIO $ run_command cmd
 401       Comment new_comment -> do
 402         liftIO $ putStrLn "Updating comment"
 403         sync_head
 404         comment new_comment
 405       Mark mrk -> add_mark mrk
 406       Merge commentFrom parents ours noff -> merge commentFrom parents ours noff
 407       UserComment _ -> pure ()
 408     pure StepNext
 409
 410 add_mark mrk = do
 411   hashNow <- fmap tsHead get >>= \case
 412                 Known h -> pure h
 413                 Sync -> do
 414                   [hashNow] <- liftIO $ Cmd.git_resolve_hashes ["HEAD"]
 415                   pure hashNow
 416   modify' $ \ts -> ts{ tsMarks = Map.insert mrk hashNow (tsMarks ts) }
 417   gitDir <- askGitDir
 418   liftIO $ appendToFile (gitDir <> "/rehi/marks") (mrk <> " " <> hashString hashNow <> "\n")
 419
 420 merge commit_refMb merge_parents_refs ours noff = do
 421   fmap ((,commit_refMb) . tsHead) get >>= \case
 422     (Known cachedHash, Just commit_ref) -> do
 423       (Commits refs byHash) <- envRest <$> ask
 424       case () of
 425         _ | Just step_hash <- Map.lookup commit_ref refs
 426           , Just step_data <- Map.lookup step_hash byHash
 427           -> fix (\rec actuals expects ->
 428                     case (actuals, expects) of
 429                       ("HEAD" : at, eh : et) -> if eh == cachedHash then rec at et else merge_new_
 430                       (ah : at, eh : et) -> do
 431                         ahHash <- resolve_ahash ah
 432                         if ByteString.isPrefixOf ahHash (hashString eh) then rec at et else merge_new_
 433                       ([], []) -> do
 434                         liftIO $ putStrLn ("Fast-forwarding unchanged merge: " <> commit_ref <> " " <> entrySubject step_data)
 435                         modify' (\s -> s{tsHead = Known step_hash})
 436                       _ -> merge_new_)
 437                 merge_parents_refs (entryParents step_data)
 438           | otherwise -> merge_new_
 439     _ -> merge_new_
 440   where
 441     merge_new_ = merge_new commit_refMb merge_parents_refs ours noff
 442
 443 merge_new :: (MonadIO m, MonadState TS m, MonadReader TE m) => Maybe ByteString -> [ByteString] -> Bool -> Bool -> m ()
 444 merge_new commit_refMb parents_refs ours noff = do
 445   [oldHead] <- fmap tsHead get >>= \case
 446     Known hash -> pure [hash]
 447     Sync -> liftIO $ Cmd.git_resolve_hashes ["HEAD"]
 448   sync_head
 449   liftIO $ putStrLn "Merging"
 450   parents <- mapM resolve_ahash parents_refs
 451   let head_pos = index_only "HEAD" parents_refs
 452   parents <- if head_pos /= 0
 453               then do
 454                 let
 455                   (pFirst : pInit, _ : pTail) = splitAt head_pos parents
 456                 liftIO $ Cmd.reset pFirst
 457                 pure (pInit ++ [hashString oldHead] ++ pTail)
 458               else pure (tail parents)
 459   liftIO $ Cmd.merge (isNothing commit_refMb) ours noff parents
 460   case commit_refMb of
 461     Just commit -> liftIO $ Cmd.commit_refMsgOnly commit
 462     _ -> pure ()
 463
 464 sync_head :: (MonadState TS m, MonadIO m) => m ()
 465 sync_head = do
 466   fmap tsHead get >>= \case
 467     Known hash -> do
 468       liftIO $ Cmd.reset $ hashString hash
 469       modify' (\t -> t{tsHead = Sync})
 470     Sync -> pure ()
 471
 472 pick hash = do
 473   env <- ask
 474   state <- get
 475   case tsHead state of
 476     Known currentHash
 477       | Just pickData <- Map.lookup (Hash hash) (teByHash env)
 478       , [pickParent] <- (entryParents pickData)
 479       , pickParent == currentHash
 480       -> do
 481           liftIO $ putStrLn ("Fast-forwarding unchanged commit: " <> entryAHash pickData <> " " <> entrySubject pickData)
 482           modify' (\s -> s{ tsHead = Known (Hash hash)})
 483     _ -> do
 484           sync_head
 485           liftIO $ Cmd.cherrypick hash
 486
 487 comment new_comment = do
 488   gitDir <- askGitDir
 489   liftIO $ writeFile (gitDir <> "/rehi/commit_msg") new_comment
 490   liftIO $ Cmd.commit_amend_msgFile (gitDir <> "/rehi/commit_msg")
 491
 492 build_rebase_sequence :: Commits -> Hash -> Hash -> [Hash] -> [Step]
 493 build_rebase_sequence commits source_from_hash source_to_hash through_hashes = from_mark ++ steps
 494   where
 495     sequence = find_sequence (commitsByHash commits) source_from_hash source_to_hash through_hashes
 496     (marks, _, _)
 497           = foldl'
 498               (\(marks, mark_num, prev_hash) step_hash ->
 499                 let (marks', mark_num') =
 500                       foldl'
 501                         (\v@(marks, mark_num) parent ->
 502                           case Map.lookup parent marks of
 503                             Just Nothing ->
 504                               (Map.insert parent (Just ("tmp_" <> pack (show mark_num))) marks
 505                               , mark_num + 1)
 506                             _ -> v)
 507                         (marks, mark_num)
 508                         (filter (/= prev_hash) $ entryParents (commitsByHash commits Map.! step_hash))
 509                 in (marks', mark_num', step_hash))
 510               (Map.fromList $ zip ([source_from_hash] ++ sequence) (repeat Nothing)
 511                , 1 :: Integer
 512                , source_from_hash)
 513               sequence
 514     from_mark = maybe [] ((:[]) . Mark) (marks Map.! source_from_hash)
 515     steps = concat $ zipWith makeStep sequence (source_from_hash : sequence)
 516     makeStep this prev = reset ++ step ++ maybe [] ((:[]) . Mark) (marks Map.! this)
 517       where
 518         thisE = commitsByHash commits Map.! this
 519         (real_prev, reset) =
 520           if prev `elem` entryParents thisE
 521             then (prev, [])
 522             else case filter (`Map.member` marks) (entryParents thisE) of
 523               (h : _) | Just m <- marks Map.! h -> (h, [Reset ("@" <> m)])
 524                       | Nothing <- marks Map.! h -> error ("Unresolved mark for " <> show h)
 525               [] -> error ("No known parents for found step " <> show this)
 526         step = case entryParents thisE of
 527           [p] -> [Pick $ entryAHash thisE]
 528           ps -> make_merge_steps thisE real_prev commits marks
 529
 530 make_merge_steps thisE real_prev commits marks = singleHead `seq` [Merge (Just ahash) parents ours False]
 531   where
 532     parents = map mkParent (entryParents thisE)
 533     mkParent p | p == real_prev = "HEAD"
 534                | Just (Just m) <- Map.lookup p marks = "@" <> m
 535                | Just Nothing <- Map.lookup p marks = error ("Unresolved mark for " <> show p)
 536                | Just e <- Map.lookup p (commitsByHash commits) = entryAHash e
 537                | True = error ("Unknown parent: " <> show p)
 538     singleHead = index_only "HEAD" parents :: Integer
 539     ahash = entryAHash thisE
 540     ours = entryTree thisE == entryTree (commitsByHash commits Map.! head (entryParents thisE) )
 541
 542 git_fetch_cli_commits from to = do
 543   Cmd.verify_cmdarg from
 544   Cmd.verify_cmdarg to
 545   git_fetch_commits ("git log -z --ancestry-path --pretty=format:%H:%h:%T:%P:%B " <> from <> ".." <> to)
 546                     (Commits Map.empty Map.empty)
 547
 548 git_fetch_commits :: (MonadIO m, MonadMask m, MonadReader (Env a) m) => ByteString -> Commits -> m Commits
 549 git_fetch_commits cmd commits = do
 550   gitDir <- askGitDir
 551   h <- liftIO $ openBinaryFile (gitDir <> "/rehi/commits") (AppendMode)
 552   liftIO $ hSetBinaryMode h True
 553   finally
 554     (do
 555       execStateT
 556         ((liftIO $ command_lines cmd '\0') >>= mapM (\case
 557           "\n" -> pure ()
 558           line -> do
 559             git_parse_commit_line line
 560             liftIO $ BC.hPut h line))
 561         commits)
 562     (liftIO $ hClose h)
 563
 564 git_load_commits = do
 565     gitDir <- askGitDir
 566     commits <- execStateT (mapFileLinesM git_parse_commit_line (gitDir <> "/rehi/commits") '\0') commitsEmpty
 567     let marksFile = gitDir <> "/rehi/marks"
 568     marks <- execStateT (liftIO (doesFileExist marksFile) `whenM` mapFileLinesM addMark marksFile '\n') Map.empty
 569     pure (commits, marks)
 570   where
 571     addMark line = do
 572       case regex_match line "^([0-9a-zA-Z_\\/]+) ([0-9a-fA-F]+)$" of
 573         Just [_, mName, mValue] -> modify' (Map.insert mName (Hash mValue))
 574         Nothing -> fail ("Ivalid mark line: " <> show line)
 575
 576 git_parse_commit_line line = do
 577   case regex_match_with_newlines line "^([0-9a-f]+):([0-9a-f]+):([0-9a-f]+):([0-9a-f ]*):(.*)$" of
 578     Just [_, Hash -> hash, ahash, Hash -> tree, map Hash . BC.split ' ' -> parents, body] -> do
 579       verify_hash hash
 580       mapM_ verify_hash parents
 581       let
 582         (subject : _) = BC.split '\n' body
 583         obj = Entry ahash hash subject parents tree body
 584       modify' (\c -> c{ commitsByHash = Map.insertWith (const id) hash obj (commitsByHash c)
 585                       , commitsRefs = Map.insertWith (\hNew hOld -> if hNew == hOld then hOld else error ("Duplicated ref with different hash: " <> show ahash <> "=>" <> show hOld <> ", " <> show hNew))
 586                                               ahash
 587                                               hash
 588                                               (commitsRefs c)})
 589     _ -> fail ("Could not parse line: " <> show line)
 590
 591 git_merge_base b1 b2 = do
 592   Cmd.verify_cmdarg b1
 593   Cmd.verify_cmdarg b2
 594   [base] <- execWriterT $ mapCmdLinesM (tell . (: []) . trim) ("git merge-base -a " <> b1 <> " " <> b2) '\n'
 595   pure base
 596
 597 verify_hash :: Monad m => Hash -> m ()
 598 verify_hash (Hash h) = case regex_match h "^[0-9a-f]{40}$" of
 599   Just _ -> pure ()
 600   Nothing -> fail ("Invalid hash: " <> show h)
 601
 602 init_save target_ref initial_branch = do
 603   gitDir <- askGitDir
 604   liftIO (doesFileExist (gitDir <> "/rehi")) `whenM` fail "already in progress"
 605   liftIO $ createDirectory (gitDir <> "/rehi")
 606   liftIO $ writeFile (gitDir <> "/rehi/target_ref") target_ref
 607   liftIO $ writeFile (gitDir <> "/rehi/initial_branch") initial_branch
 608
 609 cleanup_save :: (MonadReader (Env a) m, MonadIO m) => m ()
 610 cleanup_save = do
 611   gitDir <- askGitDir
 612   liftIO (doesDirectoryExist (gitDir <> "/rehi")) `whenM` (do
 613     let newBackup = gitDir <> "/rehi/todo.backup"
 614     liftIO (doesFileExist newBackup) `whenM`
 615               liftIO (run_command ("cp -f " <> newBackup <> " " <> gitDir <> "/rehi_todo.backup"))
 616     liftIO $ removeDirectoryRecursive (gitDir <> "/rehi"))
 617
 618 commits_get_subject (Commits refs byHash) ah = do
 619   maybe "???"
 620         (\h -> maybe "???" entrySubject $ Map.lookup h byHash)
 621         (Map.lookup ah refs)
 622
 623 save_todo todo path commits = do
 624   let
 625     (reverse -> tail, reverse -> main) = span (\case { UserComment _ -> True; TailPickWithComment _ _ -> True; _ -> False }) $ reverse todo
 626   withBinaryFile path WriteMode $ \out -> do
 627     forM_ main $ hPutStrLn out . \case
 628       Pick ah -> "pick " <> ah <> " " <> commits_get_subject commits ah
 629       Edit ah -> "edit " <> ah <> " " <> commits_get_subject commits ah
 630       Fixup ah -> "fixup " <> ah <> " " <> commits_get_subject commits ah
 631       Reset tgt -> "reset " <> tgt
 632       Exec cmd -> case regex_match cmd "\\n" of
 633                     Just _ -> error "multiline command canot be saved"
 634                     Nothing -> "exec " <> cmd
 635       Comment cmt -> string_from_todo_comment cmt
 636       Merge ref ps ours noff ->
 637         ("merge"
 638           <> (if ours then " --ours" else "")
 639           <> (if noff then " --no-ff" else "")
 640           <> maybe "" (" -c " <>) ref
 641           <> " " <> ByteString.intercalate "," ps
 642           <> maybe "" ((" " <>) . commits_get_subject commits) ref)
 643       Mark mrk -> ": " <> mrk
 644       UserComment cmt -> "# " <> cmt
 645     if (not $ null tail)
 646       then do
 647         hPutStrLn out "end"
 648         forM_ tail $ hPutStrLn out . \case
 649           UserComment cmt -> cmt
 650           TailPickWithComment ah msg
 651             -> "----- " <> ah <> " -----\n"
 652                 <> string_from_todo_comment msg
 653       else pure ()
 654
 655 string_from_todo_comment :: ByteString -> ByteString
 656 string_from_todo_comment cmt =
 657   case regex_match cmt "[^\\n]\\.[$\\n]|[^\\n]$|[^\\n]#" of
 658     Just _ -> quoted
 659     Nothing -> "comment\n" <> cmt <> if BC.last cmt == '\n' then "" else "\n" <> ".\n"
 660   where
 661     quoted = "comment " <> BC.replicate (BC.length endMark) '{' <> "\n" <> cmt <> endMark <> "\n"
 662     endMark = fix (\rec p -> if p `ByteString.isInfixOf` cmt then rec (p <> "}") else p) "}}}"
 663
 664 data ReadState = RStCommand | RStDone | RStCommentPlain ByteString | RStCommentQuoted ByteString ByteString deriving Show
 665
 666 read_todo :: (MonadIO m, MonadMask m) => ByteString -> Commits -> m [Step]
 667 read_todo path commits = do
 668     (s, todo) <- execRWST (mapFileLinesM parseLine path '\n') () RStCommand
 669     case s of
 670       RStCommand -> pure todo
 671       RStDone -> pure todo
 672       mode -> throwM $ EditError "Unterminated comment"
 673   where
 674     parseLine line = do
 675       get >>= \case
 676         RStCommand
 677           | Just [_, cmt] <- regex_match line "^#(.*)$" -> tell [UserComment cmt]
 678           | Just _ <- regex_match line "^end$" -> put RStDone
 679           | Just (_ : _ : ah : _) <- regex_match line "^(f|fixup) (\\@?[0-9a-zA-Z_\\/]+)( .*)?$"
 680               -> tell [Fixup ah]
 681           | Just (_ : _ : ah : _) <- regex_match line "^(p|pick) (\\@?[0-9a-zA-Z_\\/]+)( .*)?$"
 682               -> tell [Pick ah]
 683           | Just (_ : _ : ah : _) <- regex_match line "^(e|edit) (\\@?[0-9a-zA-Z_\\/]+)( .*)?$"
 684               -> tell [Edit ah]
 685           | Just (_ : ah : _) <- regex_match line "^reset (\\@?[0-9a-zA-Z_\\/]+)$"
 686               -> tell [Reset ah]
 687           | Just (_ : _ : cmd : _) <- regex_match line "^(x|exec) (.*)$"
 688               -> tell [Exec cmd]
 689           | Just _ <- regex_match line "^comment$" -> put $ RStCommentPlain ""
 690           | Just [_, b] <- regex_match line "^comment (\\{+)$"
 691               -> put $ RStCommentQuoted "" (BC.length b `BC.replicate` '}')
 692           | Just [_, options, _, parents] <- regex_match line "^merge(( --ours| --no-ff| -c \\@?[0-9a-zA-Z_\\/]+)*) ([^ ]+)"
 693               -> do
 694                 merge <- fix (\rec m l -> if
 695                                   | ByteString.null l -> pure m
 696                                   | Just [_, rest] <- regex_match l "^ --ours( .*)?$" -> rec m{ mergeOurs = True } rest
 697                                   | Just [_, rest] <- regex_match l "^ --no-ff( .*)?$" -> rec m{ mergeNoff = True } rest
 698                                   | Just [_, ref, rest] <- regex_match l "^ -c (\\@?[0-9a-zA-Z_\\/]+)( .*)?$" -> rec m{mergeRef = Just ref} rest
 699                                   | otherwise -> throwM $ EditError ("Unexpected merge options: " <> l))
 700                               (Merge Nothing (BC.split ',' parents) False False)
 701                               options
 702                 tell [merge]
 703           | Just [_, mrk] <- regex_match line "^: (.*)$"
 704               -> maybe (tell [Mark mrk])
 705                   (const $ throwM (EditError ("Dangerous symbols in mark name: " <> mrk)))
 706                   (regex_match mrk "[^0-9a-zA-Z_]")
 707           | Just _ <- regex_match line "^[ \\t]*$" -> pure ()
 708         RStCommentPlain cmt0
 709           | Just [_, cmt] <- regex_match line "^# (.*)$" -> tell [UserComment cmt]
 710           | line == "." -> tell [Comment cmt0] >> put RStCommand
 711           | otherwise -> put $ RStCommentPlain (cmt0 <> line <> "\n")
 712         RStCommentQuoted cmt0 quote
 713           | quote `ByteString.isSuffixOf` line -> tell [Comment (cmt0 <> ByteString.take (ByteString.length line - ByteString.length quote) line)] >> put RStCommand
 714           | otherwise -> put $ RStCommentQuoted (cmt0 <> line <> "\n") quote
 715         RStDone -> tell [UserComment line]
 716         mode -> throwM $ EditError ("Unexpected line in mode " <> BC.pack (show mode) <> ": " <> line)
 717
 718 commitsEmpty = Commits Map.empty Map.empty
 719
 720 returnC x = ContT $ const x
 721
 722 data FsThreadState = FsReady | FsFinalizeMergebases | FsWaitChildren | FsDone deriving Eq
 723
 724 data FsThread = FsThread { fsstState :: FsThreadState, fsstCurrent :: Hash, fsstTodo :: [Hash] }
 725
 726 data FsWaiter = FsWaiter { fswThread :: Int, fswLeft :: Int, fswTodo :: Set.Set Hash }
 727
 728 data FS = FS {
 729                          fssThreads :: Map.Map Int FsThread,
 730                          fssSchedule :: [Int],
 731                          fssNextThreadId :: Int,
 732                          fssChildrenWaiters :: Map.Map Hash FsWaiter,
 733                          fssTerminatingCommits :: Set.Set Hash }
 734
 735 find_sequence :: Map.Map Hash Entry -> Hash -> Hash -> [Hash] -> [Hash]
 736 find_sequence commits from to through =
 737   step (FS (Map.singleton 1 (FsThread FsReady to [])) [1] 2 Map.empty Set.empty)
 738   where
 739     children_num = Map.unionsWith (+)
 740                         ((Map.fromList $ map (,0) (from : to : Map.keys commits))
 741                         : map (Map.fromList . map (,1) . entryParents) (Map.elems commits))
 742     step = \case
 743       FS { fssSchedule = [] } -> error "No path found"
 744       s@(FS ts sc@(n : _) nextId childerWaiters terminatingCommits)
 745         | FsDone <- fsstState (ts Map.! n) -> reverse $ fsstTodo (ts Map.! n)
 746         | otherwise -> case break ((`elem` [FsReady, FsFinalizeMergebases]) . fsstState . (ts Map.!)) sc of
 747             (_, []) -> error "No thread is READY"
 748             (scH, (scC@((ts Map.!) -> FsThread curState curHash curTodo) : scT))
 749               | Set.member curHash terminatingCommits -> step s{ fssSchedule = scH ++ scT }
 750               | curState == FsFinalizeMergebases ->
 751                 let
 752                   ts' = if children_num Map.! curHash == 1
 753                           then ts
 754                           else case Map.lookup curHash childerWaiters of
 755                             Nothing -> ts
 756                             Just (FsWaiter { fswThread = waiter }) ->
 757                               Map.adjust (\ws -> ws { fsstState = FsFinalizeMergebases }) waiter ts
 758                   (new_tasks, nextId') = makeParentTasks nextId
 759                 in step (FS (Map.union (Map.fromList new_tasks) ts')
 760                             (scH ++ map fst new_tasks ++ scT)
 761                             nextId'
 762                             childerWaiters
 763                             (Set.insert curHash terminatingCommits))
 764               | curHash == from ->
 765                 let
 766                   ts' = Map.adjust (\t -> t { fsstState = FsDone }) scC ts
 767                   keepCurrent = all (`Set.member` todoSet) through
 768                   (new_tasks, nextId') = makeParentTasks nextId
 769                 in step s { fssThreads = Map.union (Map.fromList new_tasks) ts',
 770                             fssSchedule = scH ++ (if keepCurrent then [scC] else []) ++ map fst new_tasks ++ scT,
 771                             fssNextThreadId = nextId' }
 772               | children_num Map.! curHash > 1 && not (Map.member curHash childerWaiters) ->
 773                 step s { fssThreads = Map.adjust (\t -> t { fsstState = FsWaitChildren }) scC ts,
 774                          fssChildrenWaiters = Map.insert curHash
 775                                                          (FsWaiter scC ((children_num Map.! curHash) - 1) todoSet)
 776                                                          childerWaiters }
 777               | children_num Map.! curHash > 1, Just waiter <- Map.lookup curHash childerWaiters, fswLeft waiter > 0 ->
 778                 let
 779                   (todo', todoIdx') = foldl' (\(t, i) h -> if Set.member h i then (t,i) else (t ++ [h], Set.insert h i))
 780                                              (fsstTodo (ts Map.! (fswThread waiter)), fswTodo waiter)
 781                                              curTodo
 782                   left' = fswLeft waiter - 1
 783                 in step s{ fssThreads = Map.adjust (\t -> t{fsstTodo = todo',
 784                                                             fsstState = if left' == 0 then FsReady else fsstState t})
 785                                                    (fswThread waiter)
 786                                                    ts,
 787                            fssChildrenWaiters = Map.adjust (\w -> w{ fswLeft = left', fswTodo = todoIdx' }) curHash childerWaiters,
 788                            fssSchedule = scH ++ scT }
 789               | otherwise ->
 790                 let
 791                   curTodo' = curTodo ++ [curHash]
 792                   (newTasks, nextId') = makeParentTasksEx (\p -> FsThread FsReady p curTodo') nextId
 793                 in step s{ fssThreads = Map.union (Map.fromList newTasks) ts,
 794                            fssSchedule = scH ++ map fst newTasks ++ scT,
 795                            fssNextThreadId = nextId' }
 796               where
 797                 todoSet = Set.fromList curTodo
 798                 makeParentTasksEx newThread fromId =
 799                   let tasks = zip [fromId ..] $ map newThread
 800                                               $ maybe [] entryParents $ Map.lookup curHash commits
 801                       id = last (fromId : map ((+ 1) . fst) tasks)
 802                   in (tasks, id)
 803                 makeParentTasks = makeParentTasksEx (\p -> FsThread FsFinalizeMergebases p [])
 804
 805 resolve_ahash :: (MonadReader TE m, MonadState TS m) => ByteString -> m ByteString
 806 resolve_ahash ah = do
 807   refs <- fmap teRefs ask
 808   case regex_match ah "^@(.*)$" of
 809     Just [_,mrk] -> do
 810       marks <- fmap tsMarks get
 811       pure $ maybe (error ("Mark " <> show mrk<> " not found")) hashString (Map.lookup mrk marks)
 812     Nothing -> pure $ maybe ah hashString (Map.lookup ah refs)
 813
 814 git_no_uncommitted_changes :: MonadIO m => m Bool
 815 git_no_uncommitted_changes = liftIO (system "git diff-index --quiet --ignore-submodules HEAD") >>= \case
 816   ExitSuccess -> pure True
 817   _ -> pure False
 818
 819 retry :: (MonadMask m, MonadIO m) => m x -> m (Maybe x)
 820 retry func = fix $ \rec -> do
 821   res <- catch
 822           (func >>= (pure . Right))
 823           (\(EditError msg) -> pure $ Left msg)
 824   case res of
 825     Right x -> pure (Just x)
 826     Left msg -> do
 827       liftIO $ putStrLn ("Error: " <> msg)
 828       liftIO $ putStrLn "Retry (y/N)?"
 829       answer <- liftIO $ ByteString.getLine
 830       if "y" `ByteString.isPrefixOf` answer || "Y" `ByteString.isPrefixOf` answer
 831         then rec
 832         else pure Nothing
 833
 834 git_fetch_commit_list commits [] = pure commits
 835 git_fetch_commit_list commits unknowns = do
 836   let
 837     (map hashString -> us, usRest) = Prelude.splitAt 20 unknowns
 838   mapM_ Cmd.verify_cmdarg us
 839   commits <- git_fetch_commits
 840     ("git show -z --no-patch --pretty=format:%H:%h:%T:%P:%B" <> ByteString.concat (map (" " <>) us))
 841     commits
 842   git_fetch_commit_list commits usRest
 843
 844 get_env = do
 845   gitDir <- readPopen "git rev-parse --git-dir"
 846   case regex_match gitDir "^([a-zA-Z]:)?[-a-zA-Z0-9_\\.,\\/ ]+$" of
 847     Just _ -> pure $ Env gitDir ()
 848     Nothing -> fail ("Some unsupported symbols in: " <> show gitDir)
 849
 850 git_verify_clean = do
 851   git_no_uncommitted_changes `unlessM` fail "Not clean working directory"
 852   gitDir <- askGitDir
 853   liftIO (doesFileExist (gitDir <> "/rebase-apply")) `whenM` fail "git-am or rebase in progress"
 854   liftIO (doesFileExist (gitDir <> "/rebase-merge")) `whenM` fail "rebase in progress"
 855
 856 git_get_checkedout_branch = do
 857   head_path <- liftIO $ readPopen "git symbolic-ref -q HEAD"
 858   case regex_match head_path "^refs/heads/(.*)" of
 859     Just [_, p] -> pure p
 860     _ -> fail ("Unsupported ref checked-out: " ++ show head_path)
 861
 862 askGitDir :: MonadReader (Env a) m => m ByteString
 863 askGitDir = ask >>= \r -> pure (envGitDir r)
 864