app/Rehi.hs

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