-- Copyright 2013 Evan Laforge
-- This program is distributed under the terms of the GNU General Public
-- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt

-- | Undo and redo cmds and support.
module Cmd.Undo (undo, redo, maintain_history, check_save_history) where
import qualified Data.Map as Map
import qualified Data.Maybe as Maybe
import qualified Data.Text as Text

import qualified Util.Files as Files
import qualified Util.Log as Log
import qualified App.Path as Path
import qualified Cmd.Clip as Clip
import qualified Cmd.Cmd as Cmd
import qualified Cmd.Internal as Internal
import qualified Cmd.Save as Save
import qualified Cmd.SaveGit as SaveGit
import qualified Cmd.SaveGitT as SaveGitT

import qualified Ui.Block as Block
import qualified Ui.Id as Id
import qualified Ui.Transform as Transform
import qualified Ui.Ui as Ui
import qualified Ui.Update as Update

import           Global
import           Types


{- [undo-and-updates]

    Unfortunately updates get in the way of the simple "list of states" model
    and make things a bit hard to understand.

    The head of hist_past is called cur.  It starts with [] updates and when
    a new history is recorded, cur gets its updates.  So each entry has the
    updates that took it to the future, which are also the updates needed to
    move to it from the future:

    load    (a [])  <cur
    +b      (a +b)  (ab []) <cur
    +c      (a +b)  (ab +c) (abc []) <cur

    On undo, the state is set to the state before cur.  The ex-cur gets the
    updates from this previous entry and goes onto the future.  So each entry
    in the future has the updates needed to get to it from the past:

    undo +c (a +b)  (ab +c) <cur    (abc +c)
    undo +b (a +b)  <cur    (ab +b) (abc +c)

    Redo is like a normal history record, except the state and updates are
    taken from the future.  The new cur entry has [] updates, and the prev
    (the old cur) gets its updates:

    redo +b (a +b)  (ab []) <cur    (abc +c)
    redo +c (a +b)  (ab +c) (abc []) <cur
-}

-- * undo / redo

undo :: Cmd.CmdT IO ()
undo :: CmdT IO ()
undo = do
    -- If there is a suppressed record, then undo that and put it in the
    -- future.
    CmdT IO ()
record_suppressed
    History
hist <- forall (m :: * -> *) a. M m => (State -> a) -> m a
Cmd.gets State -> History
Cmd.state_history
    -- undo is asymmetrical with 'redo' because 'undo' itself is a cmd, and
    -- is happening after the state that is going to be undone.  So the current
    -- state doesn't count (it's the 'undo' cmd), the state I'm coming from is
    -- the previous one, and the one I'm going to is the twice previous one.
    let cur :: HistoryEntry
cur = History -> HistoryEntry
Cmd.hist_present History
hist
    case History -> [HistoryEntry]
Cmd.hist_past History
hist of
        HistoryEntry
prev : [HistoryEntry]
rest -> forall {m :: * -> *}.
M m =>
History -> HistoryEntry -> HistoryEntry -> [HistoryEntry] -> m ()
do_undo History
hist HistoryEntry
cur HistoryEntry
prev [HistoryEntry]
rest
        [] -> do
            Repo
repo <- forall (m :: * -> *). M m => m Repo
Save.get_git_path
            [HistoryEntry]
past <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Repo -> HistoryEntry -> IO [HistoryEntry]
load_prev Repo
repo HistoryEntry
cur
            case [HistoryEntry]
past of
                [] -> forall (m :: * -> *) a. (Stack, M m) => Text -> m a
Cmd.throw Text
"no past to undo"
                HistoryEntry
prev : [HistoryEntry]
rest -> forall {m :: * -> *}.
M m =>
History -> HistoryEntry -> HistoryEntry -> [HistoryEntry] -> m ()
do_undo History
hist HistoryEntry
cur HistoryEntry
prev [HistoryEntry]
rest
    where
    do_undo :: History -> HistoryEntry -> HistoryEntry -> [HistoryEntry] -> m ()
do_undo History
hist HistoryEntry
cur HistoryEntry
prev [HistoryEntry]
rest = do
        forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.notice forall a b. (a -> b) -> a -> b
$ Text
"undo " forall a. Semigroup a => a -> a -> a
<> HistoryEntry -> Text
hist_name HistoryEntry
cur forall a. Semigroup a => a -> a -> a
<> Text
" -> " forall a. Semigroup a => a -> a -> a
<> HistoryEntry -> Text
hist_name HistoryEntry
prev
        let damage :: UiDamage
damage = HistoryEntry -> UiDamage
Cmd.hist_damage HistoryEntry
prev
        forall (m :: * -> *). M m => (State -> State) -> m ()
Cmd.modify forall a b. (a -> b) -> a -> b
$ \State
st -> State
st
            { state_history :: History
Cmd.state_history = Cmd.History
                { hist_past :: [HistoryEntry]
Cmd.hist_past = [HistoryEntry]
rest
                , hist_present :: HistoryEntry
Cmd.hist_present = HistoryEntry
prev
                , hist_future :: [HistoryEntry]
Cmd.hist_future = HistoryEntry
cur { hist_damage :: UiDamage
Cmd.hist_damage = UiDamage
damage }
                    forall a. a -> [a] -> [a]
: History -> [HistoryEntry]
Cmd.hist_future History
hist
                , hist_last_cmd :: Maybe LastCmd
Cmd.hist_last_cmd = forall a. a -> Maybe a
Just LastCmd
Cmd.UndoRedo
                }
            , state_history_collect :: HistoryCollect
Cmd.state_history_collect = HistoryCollect
Cmd.empty_history_collect
            , state_history_config :: HistoryConfig
Cmd.state_history_config = (State -> HistoryConfig
Cmd.state_history_config State
st)
                { hist_last_commit :: Maybe Commit
Cmd.hist_last_commit = HistoryEntry -> Maybe Commit
Cmd.hist_commit HistoryEntry
prev }
            }
        -- This should be safe because these are just saved previous states.
        forall (m :: * -> *). M m => (State -> State) -> m ()
Ui.unsafe_modify forall a b. (a -> b) -> a -> b
$ State -> State -> State
merge_undo_states (HistoryEntry -> State
Cmd.hist_state HistoryEntry
prev)
        forall (m :: * -> *). M m => UiDamage -> m ()
Ui.damage UiDamage
damage
    load_prev :: Repo -> HistoryEntry -> IO [HistoryEntry]
load_prev Repo
repo = Text
-> (State -> Commit -> IO (Either Text (Maybe LoadHistory)))
-> HistoryEntry
-> IO [HistoryEntry]
load_history Text
"load_previous_history" forall a b. (a -> b) -> a -> b
$
        Repo -> State -> Commit -> IO (Either Text (Maybe LoadHistory))
SaveGit.load_previous_history Repo
repo

redo :: Cmd.CmdT IO ()
redo :: CmdT IO ()
redo = do
    History
hist <- forall (m :: * -> *) a. M m => (State -> a) -> m a
Cmd.gets State -> History
Cmd.state_history
    let cur :: HistoryEntry
cur = History -> HistoryEntry
Cmd.hist_present History
hist
    case History -> [HistoryEntry]
Cmd.hist_future History
hist of
        HistoryEntry
next : [HistoryEntry]
rest -> forall {m :: * -> *}.
M m =>
HistoryEntry
-> [HistoryEntry] -> HistoryEntry -> [HistoryEntry] -> m ()
do_redo HistoryEntry
cur (History -> [HistoryEntry]
Cmd.hist_past History
hist) HistoryEntry
next [HistoryEntry]
rest
        [] -> do
            Repo
repo <- forall (m :: * -> *). M m => m Repo
Save.get_git_path
            [HistoryEntry]
future <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Repo -> HistoryEntry -> IO [HistoryEntry]
load_next Repo
repo HistoryEntry
cur
            case [HistoryEntry]
future of
                [] -> forall (m :: * -> *) a. (Stack, M m) => Text -> m a
Cmd.throw Text
"no future to redo"
                HistoryEntry
next : [HistoryEntry]
rest -> forall {m :: * -> *}.
M m =>
HistoryEntry
-> [HistoryEntry] -> HistoryEntry -> [HistoryEntry] -> m ()
do_redo HistoryEntry
cur (History -> [HistoryEntry]
Cmd.hist_past History
hist) HistoryEntry
next [HistoryEntry]
rest
    where
    do_redo :: HistoryEntry
-> [HistoryEntry] -> HistoryEntry -> [HistoryEntry] -> m ()
do_redo HistoryEntry
cur [HistoryEntry]
past HistoryEntry
next [HistoryEntry]
rest = do
        forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.notice forall a b. (a -> b) -> a -> b
$ Text
"redo " forall a. Semigroup a => a -> a -> a
<> HistoryEntry -> Text
hist_name HistoryEntry
cur forall a. Semigroup a => a -> a -> a
<> Text
" -> " forall a. Semigroup a => a -> a -> a
<> HistoryEntry -> Text
hist_name HistoryEntry
next
        forall (m :: * -> *). M m => (State -> State) -> m ()
Cmd.modify forall a b. (a -> b) -> a -> b
$ \State
st -> State
st
            { state_history :: History
Cmd.state_history = Cmd.History
                { hist_past :: [HistoryEntry]
Cmd.hist_past =
                    HistoryEntry
cur { hist_damage :: UiDamage
Cmd.hist_damage = HistoryEntry -> UiDamage
Cmd.hist_damage HistoryEntry
next } forall a. a -> [a] -> [a]
: [HistoryEntry]
past
                , hist_present :: HistoryEntry
Cmd.hist_present = HistoryEntry
next { hist_damage :: UiDamage
Cmd.hist_damage = forall a. Monoid a => a
mempty }
                , hist_future :: [HistoryEntry]
Cmd.hist_future = [HistoryEntry]
rest
                , hist_last_cmd :: Maybe LastCmd
Cmd.hist_last_cmd = forall a. a -> Maybe a
Just LastCmd
Cmd.UndoRedo
                }
            , state_history_collect :: HistoryCollect
Cmd.state_history_collect = HistoryCollect
Cmd.empty_history_collect
            , state_history_config :: HistoryConfig
Cmd.state_history_config = (State -> HistoryConfig
Cmd.state_history_config State
st)
                { hist_last_commit :: Maybe Commit
Cmd.hist_last_commit = HistoryEntry -> Maybe Commit
Cmd.hist_commit HistoryEntry
next }
            }
        -- This should be safe because these are just saved previous states.
        forall (m :: * -> *). M m => (State -> State) -> m ()
Ui.unsafe_modify forall a b. (a -> b) -> a -> b
$ State -> State -> State
merge_undo_states (HistoryEntry -> State
Cmd.hist_state HistoryEntry
next)
        forall (m :: * -> *). M m => UiDamage -> m ()
Ui.damage forall a b. (a -> b) -> a -> b
$ HistoryEntry -> UiDamage
Cmd.hist_damage HistoryEntry
next
    load_next :: Repo -> HistoryEntry -> IO [HistoryEntry]
load_next Repo
repo = Text
-> (State -> Commit -> IO (Either Text (Maybe LoadHistory)))
-> HistoryEntry
-> IO [HistoryEntry]
load_history Text
"load_next_history" forall a b. (a -> b) -> a -> b
$
        Repo -> State -> Commit -> IO (Either Text (Maybe LoadHistory))
SaveGit.load_next_history Repo
repo

hist_name :: Cmd.HistoryEntry -> Text
hist_name :: HistoryEntry -> Text
hist_name HistoryEntry
hist = Text
"[" forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
", " (HistoryEntry -> [Text]
Cmd.hist_names HistoryEntry
hist) forall a. Semigroup a => a -> a -> a
<> Text
"] "
    forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty (HistoryEntry -> Maybe Commit
Cmd.hist_commit HistoryEntry
hist)

load_history :: Text
    -> (Ui.State -> SaveGit.Commit
        -> IO (Either Text (Maybe SaveGit.LoadHistory)))
     -> Cmd.HistoryEntry -> IO [Cmd.HistoryEntry]
load_history :: Text
-> (State -> Commit -> IO (Either Text (Maybe LoadHistory)))
-> HistoryEntry
-> IO [HistoryEntry]
load_history Text
name State -> Commit -> IO (Either Text (Maybe LoadHistory))
load HistoryEntry
hist = case HistoryEntry -> Maybe Commit
Cmd.hist_commit HistoryEntry
hist of
    Maybe Commit
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return []
    Just Commit
commit -> do
        Either Text (Maybe LoadHistory)
result <- State -> Commit -> IO (Either Text (Maybe LoadHistory))
load (HistoryEntry -> State
Cmd.hist_state HistoryEntry
hist) Commit
commit
        case Either Text (Maybe LoadHistory)
result of
            Left Text
err -> do
                forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.error forall a b. (a -> b) -> a -> b
$ Text
name forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> Text
err
                forall (m :: * -> *) a. Monad m => a -> m a
return []
            Right Maybe LoadHistory
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return []
            Right (Just LoadHistory
hist) -> forall (m :: * -> *) a. Monad m => a -> m a
return [LoadHistory -> HistoryEntry
entry LoadHistory
hist]
    where
    entry :: LoadHistory -> HistoryEntry
entry (SaveGit.LoadHistory State
state Commit
commit UiDamage
damage [Text]
names) =
        State -> UiDamage -> [Text] -> Maybe Commit -> HistoryEntry
Cmd.HistoryEntry State
state UiDamage
damage [Text]
names (forall a. a -> Maybe a
Just Commit
commit)

-- | There are certain parts of the state that I don't want to undo, so
-- inherit them from the old state.  It's confusing when undo moves a window,
-- or a selection, or changes the zoom.
merge_undo_states :: Ui.State -> Ui.State -> Ui.State
merge_undo_states :: State -> State -> State
merge_undo_states State
new State
old =
    (Namespace -> State -> State -> State
Transform.replace_namespace Namespace
Clip.clip_namespace State
old State
new)
    { state_views :: Map ViewId View
Ui.state_views = forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey
        (Map ViewId View -> ViewId -> View -> View
merge_view (State -> Map ViewId View
Ui.state_views State
old)) (State -> Map ViewId View
Ui.state_views State
new)
    , state_blocks :: Map BlockId Block
Ui.state_blocks = forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey
        (Map BlockId Block -> BlockId -> Block -> Block
merge_block (State -> Map BlockId Block
Ui.state_blocks State
old)) (State -> Map BlockId Block
Ui.state_blocks State
new)
    -- Previously I would keep the old Ui.state_config.  I don't remember
    -- exactly why, but it turned out to be confusing when I couldn't undo
    -- config changes.
    }

merge_view :: Map ViewId Block.View -> ViewId -> Block.View -> Block.View
merge_view :: Map ViewId View -> ViewId -> View -> View
merge_view Map ViewId View
old_views ViewId
view_id View
new = forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault View
new ViewId
view_id Map ViewId View
old_views

merge_block :: Map BlockId Block.Block -> BlockId -> Block.Block
    -> Block.Block
merge_block :: Map BlockId Block -> BlockId -> Block -> Block
merge_block Map BlockId Block
old_blocks BlockId
block_id Block
new = case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup BlockId
block_id Map BlockId Block
old_blocks of
    Maybe Block
Nothing -> Block
new
    Just Block
old -> Block
new { block_config :: Config
Block.block_config = Block -> Config
Block.block_config Block
old }

-- | Since 'merge_undo_states' makes sure the clip\/ namespace doesn't
-- participate in undo\/redo, I don't need to record if I have only those kind
-- of updates.
is_clip_update :: Update.UiUpdate -> Bool
is_clip_update :: UiUpdate -> Bool
is_clip_update = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False ((forall a. Eq a => a -> a -> Bool
==Namespace
Clip.clip_namespace) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Namespace
Id.id_namespace)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. Update t State -> Maybe Id
Update.update_id


-- * responder support

-- | This is the toplevel function to record one Cmd's worth of history.
--
-- It's called by the responder after the Cmds are run and the updates are
-- available.
maintain_history :: Ui.State -> Cmd.State -> [Update.UiUpdate] -> IO Cmd.State
maintain_history :: State -> State -> [UiUpdate] -> IO State
maintain_history State
ui_state State
cmd_state [UiUpdate]
updates =
    State -> History -> HistoryCollect -> [SaveHistory] -> IO State
save_history State
cmd_state History
hist HistoryCollect
collect [SaveHistory]
uncommitted
    where
    (History
hist, HistoryCollect
collect, [SaveHistory]
uncommitted) = [UiUpdate]
-> State -> State -> (History, HistoryCollect, [SaveHistory])
update_history [UiUpdate]
updates State
ui_state State
cmd_state

-- | Save the suppressed history, if there is any.
record_suppressed :: Cmd.CmdT IO ()
record_suppressed :: CmdT IO ()
record_suppressed = do
    State
cmd_state <- forall (m :: * -> *). M m => m State
Cmd.get
    let uncommitted :: [SaveHistory]
uncommitted = forall a. Maybe a -> [a]
Maybe.maybeToList forall a b. (a -> b) -> a -> b
$ HistoryCollect -> Maybe SaveHistory
Cmd.state_suppressed forall a b. (a -> b) -> a -> b
$
            State -> HistoryCollect
Cmd.state_history_collect State
cmd_state
        hist :: History
hist = State -> History
Cmd.state_history State
cmd_state
        collect :: HistoryCollect
collect = HistoryCollect
Cmd.empty_history_collect
    forall (m :: * -> *). M m => State -> m ()
Cmd.put forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (State -> History -> HistoryCollect -> [SaveHistory] -> IO State
save_history State
cmd_state History
hist HistoryCollect
collect [SaveHistory]
uncommitted)

-- | Write the given 'SaveGit.SaveHistory's to disk (if I'm recording into
-- git), and update the Cmd.State accordingly.
save_history :: Cmd.State -> Cmd.History -> Cmd.HistoryCollect
    -> [SaveGit.SaveHistory] -> IO Cmd.State
save_history :: State -> History -> HistoryCollect -> [SaveHistory] -> IO State
save_history State
cmd_state History
hist HistoryCollect
collect [SaveHistory]
uncommitted = do
    let user :: User
user = Config -> User
Cmd.config_git_user forall a b. (a -> b) -> a -> b
$ State -> Config
Cmd.state_config State
cmd_state
    [HistoryEntry]
entries <- case State -> Maybe (Canonical, Commit)
Internal.can_checkpoint State
cmd_state of
        Just (Canonical
repo, Commit
prev_commit) ->
            User -> Repo -> Commit -> [SaveHistory] -> IO [HistoryEntry]
commit_entries User
user (Canonical -> Repo
Path.to_path Canonical
repo) Commit
prev_commit [SaveHistory]
uncommitted
        Maybe (Canonical, Commit)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Maybe Commit -> SaveHistory -> HistoryEntry
history_entry forall a. Maybe a
Nothing) [SaveHistory]
uncommitted
    let (HistoryEntry
present, [HistoryEntry]
past) = HistoryEntry -> [HistoryEntry] -> (HistoryEntry, [HistoryEntry])
bump_damage (History -> HistoryEntry
Cmd.hist_present History
hist) [HistoryEntry]
entries
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ State
cmd_state
        { state_history :: History
Cmd.state_history = History
hist
            { hist_past :: [HistoryEntry]
Cmd.hist_past = forall a. Int -> [a] -> [a]
take Int
keep ([HistoryEntry]
past forall a. [a] -> [a] -> [a]
++ History -> [HistoryEntry]
Cmd.hist_past History
hist)
            , hist_present :: HistoryEntry
Cmd.hist_present = HistoryEntry
present
            , hist_future :: [HistoryEntry]
Cmd.hist_future = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [HistoryEntry]
entries
                then History -> [HistoryEntry]
Cmd.hist_future History
hist else []
            , hist_last_cmd :: Maybe LastCmd
Cmd.hist_last_cmd = forall a. Maybe a
Nothing
            }
        , state_history_collect :: HistoryCollect
Cmd.state_history_collect = HistoryCollect
collect
        , state_history_config :: HistoryConfig
Cmd.state_history_config = (State -> HistoryConfig
Cmd.state_history_config State
cmd_state)
            { hist_last_commit :: Maybe Commit
Cmd.hist_last_commit = HistoryEntry -> Maybe Commit
Cmd.hist_commit HistoryEntry
present
                forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> HistoryConfig -> Maybe Commit
Cmd.hist_last_commit (State -> HistoryConfig
Cmd.state_history_config State
cmd_state)
            }
        }
    where
    keep :: Int
keep = HistoryConfig -> Int
Cmd.hist_keep (State -> HistoryConfig
Cmd.state_history_config State
cmd_state)

-- | Only do this if I would have written something.  For that I need the
-- diffs.
check_save_history :: Cmd.State -> IO (Maybe Text)
check_save_history :: State -> IO (Maybe Text)
check_save_history State
cmd_state = case State -> Maybe (Canonical, Commit)
Internal.can_checkpoint State
cmd_state of
    Just (Canonical
repo, Commit
_) -> forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (Repo -> IO Bool
Files.writable (Canonical -> Repo
Path.to_path Canonical
repo)) (forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing)
        (forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text
"repo not writable: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Canonical
repo)
    Maybe (Canonical, Commit)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

-- | The present is expected to have no damage, so bump the damage off the
-- new present onto the old present, as described in [undo-and-updates].
bump_damage :: Cmd.HistoryEntry -> [Cmd.HistoryEntry]
    -> (Cmd.HistoryEntry, [Cmd.HistoryEntry])
bump_damage :: HistoryEntry -> [HistoryEntry] -> (HistoryEntry, [HistoryEntry])
bump_damage HistoryEntry
old_cur [] = (HistoryEntry
old_cur, [])
bump_damage HistoryEntry
old_cur (HistoryEntry
new_cur : [HistoryEntry]
news) =
    -- All I want to do is bump the updates from new_cur to old_cur, but
    -- suppressed records means there can be multiple histories recorded at
    -- once, which makes this a bit more of a hassle.
    (HistoryEntry
present, forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith HistoryEntry -> HistoryEntry -> HistoryEntry
bump (HistoryEntry
new_cur forall a. a -> [a] -> [a]
: [HistoryEntry]
entries) [HistoryEntry]
entries)
    where
    entries :: [HistoryEntry]
entries = [HistoryEntry]
news forall a. [a] -> [a] -> [a]
++ [HistoryEntry
old_cur]
    present :: HistoryEntry
present = HistoryEntry
new_cur { hist_damage :: UiDamage
Cmd.hist_damage = forall a. Monoid a => a
mempty }
    bump :: HistoryEntry -> HistoryEntry -> HistoryEntry
bump HistoryEntry
p HistoryEntry
c = HistoryEntry
c { hist_damage :: UiDamage
Cmd.hist_damage = HistoryEntry -> UiDamage
Cmd.hist_damage HistoryEntry
p }

-- | Convert 'SaveGit.SaveHistory's to 'Cmd.HistoryEntry's by writing the
-- commits to disk.
commit_entries :: SaveGitT.User -> SaveGit.Repo -> SaveGit.Commit
    -> [SaveGit.SaveHistory] -> IO [Cmd.HistoryEntry]
commit_entries :: User -> Repo -> Commit -> [SaveHistory] -> IO [HistoryEntry]
commit_entries User
_ Repo
_ Commit
_ [] = forall (m :: * -> *) a. Monad m => a -> m a
return []
commit_entries User
user Repo
repo Commit
prev_commit (SaveHistory
hist0:[SaveHistory]
hists) = do
    let hist :: SaveHistory
hist = Commit -> SaveHistory -> SaveHistory
set_commit Commit
prev_commit SaveHistory
hist0
    Either Text Commit
result <- User -> Repo -> SaveHistory -> IO (Either Text Commit)
SaveGit.checkpoint User
user Repo
repo SaveHistory
hist
    case Either Text Commit
result of
        Left Text
err -> do
            -- This can happen if the repo is read-only.
            forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.warn forall a b. (a -> b) -> a -> b
$ Text
"error committing history: " forall a. Semigroup a => a -> a -> a
<> Text
err
            forall (m :: * -> *) a. Monad m => a -> m a
return []
        Right Commit
commit -> do
            [HistoryEntry]
entries <- User -> Repo -> Commit -> [SaveHistory] -> IO [HistoryEntry]
commit_entries User
user Repo
repo Commit
commit [SaveHistory]
hists
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Maybe Commit -> SaveHistory -> HistoryEntry
history_entry (forall a. a -> Maybe a
Just Commit
commit) SaveHistory
hist forall a. a -> [a] -> [a]
: [HistoryEntry]
entries
    where
    set_commit :: Commit -> SaveHistory -> SaveHistory
set_commit Commit
commit (SaveGit.SaveHistory State
state Maybe Commit
_ [UiUpdate]
updates [Text]
names) =
        State -> Maybe Commit -> [UiUpdate] -> [Text] -> SaveHistory
SaveGit.SaveHistory State
state (forall a. a -> Maybe a
Just Commit
commit) [UiUpdate]
updates [Text]
names

-- | Create a 'Cmd.HistoryEntry' from a 'SaveGit.SaveHistory'.
--
-- The SaveHistory has a commit, but it's the commit that this history is
-- relative to (the previous commit), while the commit of the HistoryEntry is
-- the commit that this history was saved as (the current commit).
history_entry :: Maybe SaveGit.Commit -> SaveGit.SaveHistory -> Cmd.HistoryEntry
history_entry :: Maybe Commit -> SaveHistory -> HistoryEntry
history_entry Maybe Commit
commit (SaveGit.SaveHistory State
state Maybe Commit
_ [UiUpdate]
updates [Text]
names) =
    -- Recover the CmdUpdates out of the UiUpdates.  I only have to remember
    -- the updates that diff won't recreate for me.
    State -> UiDamage -> [Text] -> Maybe Commit -> HistoryEntry
Cmd.HistoryEntry State
state (forall b a. Monoid b => (a -> b) -> [a] -> b
mconcatMap UiUpdate -> UiDamage
Update.to_damage [UiUpdate]
updates) [Text]
names Maybe Commit
commit

-- | Integrate the latest updates into the history.  This could mean
-- accumulating them if history record is suppressed, or putting them into
-- new 'SaveGit.SaveHistory's if it isn't.
update_history :: [Update.UiUpdate] -> Ui.State -> Cmd.State
    -> (Cmd.History, Cmd.HistoryCollect, [SaveGit.SaveHistory])
update_history :: [UiUpdate]
-> State -> State -> (History, HistoryCollect, [SaveHistory])
update_history [UiUpdate]
updates State
ui_state State
cmd_state
    | Just (Cmd.Load Maybe Commit
commit [Text]
names) <- History -> Maybe LastCmd
Cmd.hist_last_cmd History
hist =
        -- Switching over to someone else's history.  Wipe out existing
        -- history and record the current state as a commit.
        let new_hist :: History
new_hist = Cmd.History
                { hist_past :: [HistoryEntry]
Cmd.hist_past = []
                , hist_present :: HistoryEntry
Cmd.hist_present = Cmd.HistoryEntry
                    { hist_state :: State
hist_state = State
ui_state
                    , hist_damage :: UiDamage
hist_damage = forall a. Monoid a => a
mempty
                    , hist_names :: [Text]
hist_names = [Text]
names
                    , hist_commit :: Maybe Commit
hist_commit = Maybe Commit
commit
                    }
                , hist_future :: [HistoryEntry]
Cmd.hist_future = []
                , hist_last_cmd :: Maybe LastCmd
Cmd.hist_last_cmd = forall a. Maybe a
Nothing
                }
        in (History
new_hist, HistoryCollect
Cmd.empty_history_collect, [])
    | Just LastCmd
Cmd.UndoRedo <- History -> Maybe LastCmd
Cmd.hist_last_cmd History
hist =
        -- If I get an undo while a cmd is suppressed, the last state change
        -- will be undone and the suppressed state change will lost entirely.
        -- This seems basically reasonable, since you could see it as an edit
        -- transaction that was cancelled.
        (History
hist, HistoryCollect
Cmd.empty_history_collect, [])
    | Bool
otherwise =
        let ([SaveHistory]
entries, HistoryCollect
collect) = [UiUpdate] -> State -> State -> ([SaveHistory], HistoryCollect)
record_history [UiUpdate]
updates State
ui_state State
cmd_state
        in (History
hist, HistoryCollect
collect, [SaveHistory]
entries)
    where hist :: History
hist = State -> History
Cmd.state_history State
cmd_state

-- | Get any history entries that should be saved, and the new HistoryCollect.
-- There may be no saveable history if this cmd doesn't need to be recorded
-- or was suppressed, and there may be more than one if a suppressed history
-- must now be recorded.
record_history :: [Update.UiUpdate] -> Ui.State -> Cmd.State
    -> ([SaveGit.SaveHistory], Cmd.HistoryCollect)
record_history :: [UiUpdate] -> State -> State -> ([SaveHistory], HistoryCollect)
record_history [UiUpdate]
updates State
ui_state State
cmd_state
    | Bool -> Bool
not Bool
is_recordable Bool -> Bool -> Bool
&& forall a. Maybe a -> Bool
Maybe.isNothing Maybe EditMode
suppress =
        ([], (State -> HistoryCollect
Cmd.state_history_collect State
cmd_state) { state_cmd_names :: [Text]
Cmd.state_cmd_names = [] })
    | Bool
is_suppressed = (,) [] forall a b. (a -> b) -> a -> b
$
        HistoryCollect
Cmd.empty_history_collect
            { state_suppressed :: Maybe SaveHistory
Cmd.state_suppressed =
                forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Maybe SaveHistory -> SaveHistory -> SaveHistory
merge_into_suppressed Maybe SaveHistory
suppressed_entry SaveHistory
cur_entry
            , state_suppress_edit :: Maybe EditMode
Cmd.state_suppress_edit =
                HistoryCollect -> Maybe EditMode
Cmd.state_suppress_edit (State -> HistoryCollect
Cmd.state_history_collect State
cmd_state)
            }
    | Bool
otherwise = ([SaveHistory]
entries, HistoryCollect
Cmd.empty_history_collect)
    where
    is_suppressed :: Bool
is_suppressed =
        Maybe EditMode
suppress forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just (EditState -> EditMode
Cmd.state_edit_mode (State -> EditState
Cmd.state_edit State
cmd_state))
    is_recordable :: Bool
is_recordable = [UiUpdate] -> Bool
should_record [UiUpdate]
updates
    entries :: [SaveHistory]
entries = if Bool
is_recordable then [SaveHistory
cur_entry] else []
        forall a. [a] -> [a] -> [a]
++ forall a. Maybe a -> [a]
Maybe.maybeToList Maybe SaveHistory
suppressed_entry
    -- Set the commit to Nothing for now, it will be filled in by
    -- 'commit_entries'.
    cur_entry :: SaveHistory
cur_entry = State -> Maybe Commit -> [UiUpdate] -> [Text] -> SaveHistory
SaveGit.SaveHistory State
ui_state forall a. Maybe a
Nothing [UiUpdate]
updates [Text]
names
    Cmd.HistoryCollect
        { state_cmd_names :: HistoryCollect -> [Text]
Cmd.state_cmd_names = [Text]
names
        , state_suppress_edit :: HistoryCollect -> Maybe EditMode
Cmd.state_suppress_edit = Maybe EditMode
suppress
        , state_suppressed :: HistoryCollect -> Maybe SaveHistory
Cmd.state_suppressed = Maybe SaveHistory
suppressed_entry
        } = State -> HistoryCollect
Cmd.state_history_collect State
cmd_state

merge_into_suppressed :: Maybe SaveGit.SaveHistory -> SaveGit.SaveHistory
    -> SaveGit.SaveHistory
merge_into_suppressed :: Maybe SaveHistory -> SaveHistory -> SaveHistory
merge_into_suppressed Maybe SaveHistory
Nothing SaveHistory
ent = SaveHistory
ent
merge_into_suppressed (Just (SaveGit.SaveHistory State
_ Maybe Commit
_ [UiUpdate]
updates1 [Text]
names1))
        (SaveGit.SaveHistory State
state2 Maybe Commit
commit2 [UiUpdate]
updates2 [Text]
_) =
    -- Keep the name of the first suppressed cmd.  The rest are likely to be
    -- either duplicates or unrecorded cmds like selection setting.
    State -> Maybe Commit -> [UiUpdate] -> [Text] -> SaveHistory
SaveGit.SaveHistory State
state2 Maybe Commit
commit2 ([UiUpdate]
updates1 forall a. [a] -> [a] -> [a]
++ [UiUpdate]
updates2) [Text]
names1

-- | True if these updates are interesting enough to record an undo state for.
should_record :: [Update.UiUpdate] -> Bool
should_record :: [UiUpdate] -> Bool
should_record = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any UiUpdate -> Bool
SaveGit.should_record forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. UiUpdate -> Bool
is_clip_update)