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

{- | Functions to save and restore state to and from files.

    The naming convention is that @load@ and @save@ functions either load
    the given file, replace the state with it, and set the SaveFile, or save
    the current state and set the SaveFile.  @read@ and @write@ functions
    are lower level and either read the file and return the state, or write the
    given state, without messing with the SaveFile.
-}
module Cmd.Save (
    -- * quit
    soft_quit, hard_quit
    -- * universal
    , save, load, load_force, read, read_, load_template
    , infer_save_type
    -- * state
    , save_state, save_state_as, load_state
    , read_state, read_state_, write_state
    , write_current_state
    -- ** path
    , get_state_path, state_path_for_repo, infer_state_path
    -- * git
    , save_git, save_git_as, load_git, revert
    , get_git_path
    -- * config
    , save_allocations, load_allocations
    -- * misc
    , save_views
) where
import           Prelude hiding (read)
import qualified Control.Exception as Exception
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Text as Text
import qualified Data.Time as Time

import qualified System.Directory as Directory
import qualified System.FilePath as FilePath
import           System.FilePath ((</>))

import qualified Util.Files as Files
import qualified Util.Git as Git
import qualified Util.Lists as Lists
import qualified Util.Log as Log
import qualified Util.Serialize as Serialize
import qualified Util.Texts as Texts
import qualified Util.Thread as Thread

import qualified App.Config as Config
import qualified App.Path as Path
import qualified Cmd.Clip as Clip
import qualified Cmd.Cmd as Cmd
import qualified Cmd.Play as Play
import qualified Cmd.SaveGit as SaveGit
import qualified Cmd.SaveGitT as SaveGitT
import qualified Cmd.Serialize

import qualified Ui.Id as Id
import qualified Ui.Transform as Transform
import qualified Ui.Ui as Ui
import qualified Ui.UiConfig as UiConfig

import           Global


-- * quit

-- | Warn and abort if there is unsaved data, otherwise quit.
soft_quit :: Cmd.CmdT IO Cmd.Status
soft_quit :: CmdT IO Status
soft_quit = forall (m :: * -> *). M m => m (Maybe Text)
check_unsaved_data forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just Text
msg -> do
        forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.warn forall a b. (a -> b) -> a -> b
$ Text
"refusing to quit: " forall a. Semigroup a => a -> a -> a
<> Text
msg
        forall (m :: * -> *) a. Monad m => a -> m a
return Status
Cmd.Done
    Maybe Text
Nothing -> CmdT IO Status
hard_quit

check_unsaved_data :: Cmd.M m => m (Maybe Text)
check_unsaved_data :: forall (m :: * -> *). M m => m (Maybe Text)
check_unsaved_data = forall (m :: * -> *) a. M m => (State -> a) -> m a
Cmd.gets State -> Saved
Cmd.state_saved forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Cmd.Saved SavedState
Cmd.UnsavedChanges Bool
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Text
"unsaved changes"
    Cmd.Saved SavedState
_ Bool
True ->
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Text
"repl editor is open, possibly with unsaved changes"
    Saved
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

-- | Quit.  If there is unsaved data, it will be discarded!
hard_quit :: Cmd.CmdT IO Cmd.Status
hard_quit :: CmdT IO Status
hard_quit = CmdT IO Status
Play.cmd_stop forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Status
Cmd.Quit

-- * universal

-- | Save to the current 'Cmd.state_save_file', or create a new git repo if
-- there is none.
save :: Cmd.CmdT IO ()
save :: CmdT IO ()
save = forall (m :: * -> *) a. M m => (State -> a) -> m a
Cmd.gets State -> Maybe (Writable, SaveFile)
Cmd.state_save_file forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe (Writable, SaveFile)
Nothing -> CmdT IO ()
save_git
    -- Try to override Cmd.Writable on an explicit save.  If it's still
    -- read only, this should throw an exception.
    Just (Writable
_, Cmd.SaveRepo Canonical
repo) -> [Char] -> CmdT IO ()
save_git_as (Canonical -> [Char]
Path.to_path Canonical
repo)
    Just (Writable
_, Cmd.SaveState Canonical
fn) -> [Char] -> CmdT IO ()
save_state_as (Canonical -> [Char]
Path.to_path Canonical
fn)

-- | Like 'read', but replace the current state and set 'Cmd.state_save_file'.
load :: FilePath -> Cmd.CmdT IO ()
load :: [Char] -> CmdT IO ()
load [Char]
path = forall (m :: * -> *). M m => m (Maybe Text)
check_unsaved_data forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just Text
msg -> forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.warn forall a b. (a -> b) -> a -> b
$ Text
"refusing to load a new score: " forall a. Semigroup a => a -> a -> a
<> Text
msg
    Maybe Text
Nothing -> [Char] -> CmdT IO ()
load_force [Char]
path

load_force :: FilePath -> Cmd.CmdT IO ()
load_force :: [Char] -> CmdT IO ()
load_force [Char]
path = do
    (State
state, StateSaveFile
save_file) <- [Char] -> CmdT IO (State, StateSaveFile)
read [Char]
path
    StateSaveFile -> State -> CmdT IO ()
set_loaded_state StateSaveFile
save_file State
state

-- | Try to guess whether the given path is a git save or state save.  If it's
-- a directory, look inside for a .git or .state save.
read :: FilePath -> Cmd.CmdT IO (Ui.State, StateSaveFile)
read :: [Char] -> CmdT IO (State, StateSaveFile)
read [Char]
path = do
    [Char]
path <- [Char] -> CmdT IO [Char]
expand_filename [Char]
path
    SaveFile
save <- forall (m :: * -> *) err a.
(Stack, M m) =>
(err -> Text) -> Either err a -> m a
Cmd.require_right (Text
"read: "<>) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ([Char] -> IO (Either Text SaveFile)
infer_save_type [Char]
path)
    case SaveFile
save of
        Cmd.SaveRepo Canonical
repo -> [Char] -> Maybe Commit -> CmdT IO (State, StateSaveFile)
read_git (Canonical -> [Char]
Path.to_path Canonical
repo) forall a. Maybe a
Nothing
        Cmd.SaveState Canonical
fn -> [Char] -> CmdT IO (State, StateSaveFile)
read_state (Canonical -> [Char]
Path.to_path Canonical
fn)

-- | Low level 'read'.
read_ :: FilePath -> IO (Either Text Ui.State)
read_ :: [Char] -> IO (Either Text State)
read_ [Char]
path = [Char] -> IO (Either Text SaveFile)
infer_save_type [Char]
path forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left Text
err -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"read " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt [Char]
path forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> Text
err
    Right SaveFile
save -> case SaveFile
save of
        Cmd.SaveState Canonical
fname -> forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall a. Pretty a => a -> Text
pretty forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO (Either UnserializeError State)
read_state_ (Canonical -> [Char]
Path.to_path Canonical
fname)
        Cmd.SaveRepo Canonical
repo ->
            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {a} {b} {c}. (a, b, c) -> a
extract forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> Maybe Commit -> IO (Either Text (State, Commit, [Text]))
read_git_ (Canonical -> [Char]
Path.to_path Canonical
repo) forall a. Maybe a
Nothing
            where extract :: (a, b, c) -> a
extract (a
state, b
_, c
_) = a
state

-- | Like 'load', but don't set SaveFile, so you can't overwrite the loaded
-- file when you save.
load_template :: FilePath -> Cmd.CmdT IO ()
load_template :: [Char] -> CmdT IO ()
load_template [Char]
fn = do
    (State
state, StateSaveFile
_) <- [Char] -> CmdT IO (State, StateSaveFile)
read [Char]
fn
    StateSaveFile -> State -> CmdT IO ()
set_loaded_state forall a. Maybe a
Nothing State
state
    UTCTime
now <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ IO UTCTime
Time.getCurrentTime
    forall (m :: * -> *). M m => (Config -> Config) -> m ()
Ui.modify_config forall a b. (a -> b) -> a -> b
$ Config :-> Meta
UiConfig.metaforall a b c. Lens a b -> Lens b c -> Lens a c
#Meta :-> UTCTime
UiConfig.creation forall f a. Lens f a -> a -> f -> f
#= UTCTime
now

-- | Given a path, which is either a file or a directory, try to figure out
-- what to load.  Saves can be either a plain saved state, or a directory
-- containing either a git repo @save.git@, or a state @save.state@.  If
-- both are present, the git repo is preferred.
infer_save_type :: FilePath -> IO (Either Text Cmd.SaveFile)
infer_save_type :: [Char] -> IO (Either Text SaveFile)
infer_save_type [Char]
path = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {b}. Either Text b -> Either Text b
prepend forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => [(m Bool, m a)] -> m a -> m a
condM
    [ (forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Char] -> Bool
SaveGit.is_git [Char]
path,
        forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. Canonical -> SaveFile
Cmd.SaveRepo forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO Canonical
Path.canonical [Char]
path)
    , ([Char] -> IO Bool
is_dir [Char]
path, forall (m :: * -> *) a. Monad m => [(m Bool, m a)] -> m a -> m a
condM
        [ ([Char] -> IO Bool
is_dir [Char]
git_fn, forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. Canonical -> SaveFile
Cmd.SaveRepo forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO Canonical
Path.canonical [Char]
git_fn)
        , ([Char] -> IO Bool
is_file [Char]
state_fn, forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. Canonical -> SaveFile
Cmd.SaveState forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO Canonical
Path.canonical [Char]
state_fn)
        ] forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"directory contains neither " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
txt [Char]
git_fn
            forall a. Semigroup a => a -> a -> a
<> Text
" nor " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
txt [Char]
state_fn)
    , ([Char] -> IO Bool
is_file [Char]
path, forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. Canonical -> SaveFile
Cmd.SaveState forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO Canonical
Path.canonical [Char]
path)
    ] forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left Text
"file not found"
    where
    prepend :: Either Text b -> Either Text b
prepend (Left Text
err) = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ [Char] -> Text
txt [Char]
path forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> Text
err
    prepend (Right b
val) = forall a b. b -> Either a b
Right b
val
    git_fn :: [Char]
git_fn = [Char]
path [Char] -> [Char] -> [Char]
</> [Char]
default_git
    state_fn :: [Char]
state_fn = [Char]
path [Char] -> [Char] -> [Char]
</> [Char]
default_state
    is_dir :: [Char] -> IO Bool
is_dir = [Char] -> IO Bool
Directory.doesDirectoryExist
    is_file :: [Char] -> IO Bool
is_file = [Char] -> IO Bool
Directory.doesFileExist

-- | Like guard cases but with monadic conditions.
condM :: Monad m => [(m Bool, m a)] -> m a -> m a
condM :: forall (m :: * -> *) a. Monad m => [(m Bool, m a)] -> m a -> m a
condM [] m a
consequent = m a
consequent
condM ((m Bool
condition, m a
result) : [(m Bool, m a)]
rest) m a
consequent =
    forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM m Bool
condition m a
result (forall (m :: * -> *) a. Monad m => [(m Bool, m a)] -> m a -> m a
condM [(m Bool, m a)]
rest m a
consequent)

-- * expand path

-- | Expand `-delimited macros to make a filepath.
expand_filename :: FilePath -> Cmd.CmdT IO FilePath
expand_filename :: [Char] -> CmdT IO [Char]
expand_filename = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> [Char]
untxt forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
Monad m =>
Bool -> Char -> (Text -> m Text) -> Text -> m Text
Texts.mapDelimitedM Bool
False Char
'`' Text -> CmdT IO Text
expand forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
txt
    where
    expand :: Text -> CmdT IO Text
expand Text
text = case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
text [(Text, CmdT IO Text)]
filename_macros of
        Just CmdT IO Text
get -> CmdT IO Text
get
        Maybe (CmdT IO Text)
Nothing -> forall (m :: * -> *) a. (Stack, M m) => Text -> m a
Cmd.throw forall a b. (a -> b) -> a -> b
$ Text
"unknown macro " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Text
text
            forall a. Semigroup a => a -> a -> a
<> Text
", known macros are: "
            forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
", " (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Text, CmdT IO Text)]
filename_macros)

filename_macros :: [(Text, Cmd.CmdT IO Text)]
filename_macros :: [(Text, CmdT IO Text)]
filename_macros =
    [ (Text
"y-m-d", forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Text
date)
    , (Text
"d", do
        [Char]
dir <- forall (m :: * -> *) a. (Stack, M m) => Text -> Maybe a -> m a
Cmd.require Text
"`d` requires a save dir"
            forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a. M m => (State -> a) -> m a
Cmd.gets State -> Maybe [Char]
Cmd.state_save_dir
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Char] -> Text
txt [Char]
dir)
    ]

date :: IO Text
date :: IO Text
date = do
    TimeZone
tz <- IO TimeZone
Time.getCurrentTimeZone
    LocalTime
today <- TimeZone -> UTCTime -> LocalTime
Time.utcToLocalTime TimeZone
tz forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime
Time.getCurrentTime
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Char] -> Text
txt forall a b. (a -> b) -> a -> b
$ forall t. FormatTime t => TimeLocale -> [Char] -> t -> [Char]
Time.formatTime TimeLocale
Time.defaultTimeLocale [Char]
"%y-%m-%d" LocalTime
today

-- * plain serialize

save_state :: Cmd.CmdT IO ()
save_state :: CmdT IO ()
save_state = [Char] -> CmdT IO ()
save_state_as forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a. (Stack, M m) => Text -> Maybe a -> m a
Cmd.require Text
"can't save, no save file"
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). M m => m (Maybe [Char])
get_state_path

-- | Save the state to the given file and set 'Cmd.state_save_file'.
--
-- The directory of the filename will become the project directory, so things
-- like the saved REPL history and the ly subdirectory will go there.
save_state_as :: FilePath -> Cmd.CmdT IO ()
save_state_as :: [Char] -> CmdT IO ()
save_state_as [Char]
fname = do
    [Char]
fname <- [Char] -> CmdT IO [Char]
write_current_state [Char]
fname
    StateSaveFile -> SaveDirection -> CmdT IO ()
set_save_file (forall a. a -> Maybe a
Just (Writable
Cmd.ReadWrite, [Char] -> SaveFile
SaveState [Char]
fname)) SaveDirection
Save

write_current_state :: FilePath -> Cmd.CmdT IO FilePath
write_current_state :: [Char] -> CmdT IO [Char]
write_current_state [Char]
fname = do
    [Char]
fname <- [Char] -> CmdT IO [Char]
expand_filename [Char]
fname
    State
state <- forall (m :: * -> *). M m => m State
Ui.get
    ((), Metric Seconds
metric) <- forall a. Text -> IO a -> CmdT IO a
rethrow_io Text
"write_current_state" forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) a. MonadIO m => m a -> m (a, Metric Seconds)
Thread.timeAction forall a b. (a -> b) -> a -> b
$ [Char] -> State -> IO ()
write_state [Char]
fname State
state
    forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.notice forall a b. (a -> b) -> a -> b
$ Text
"wrote state to " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt [Char]
fname
        forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> State -> Text
Transform.short_stats State
state
        forall a. Semigroup a => a -> a -> a
<> Text
", took " forall a. Semigroup a => a -> a -> a
<> Metric Seconds -> Text
Thread.showMetric Metric Seconds
metric
    forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
fname

write_state :: FilePath -> Ui.State -> IO ()
write_state :: [Char] -> State -> IO ()
write_state [Char]
fname State
state = do
    UTCTime
now <- IO UTCTime
Time.getCurrentTime
    forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a. Serialize a => Magic a -> [Char] -> a -> IO Bool
Serialize.serialize Magic State
Cmd.Serialize.score_magic [Char]
fname forall a b. (a -> b) -> a -> b
$
        Lens State Config
Ui.configforall a b c. Lens a b -> Lens b c -> Lens a c
#Config :-> Meta
UiConfig.metaforall a b c. Lens a b -> Lens b c -> Lens a c
#Meta :-> UTCTime
UiConfig.last_save forall f a. Lens f a -> a -> f -> f
#= UTCTime
now forall a b. (a -> b) -> a -> b
$
        State -> State
Ui.clear State
state

load_state :: FilePath -> Cmd.CmdT IO ()
load_state :: [Char] -> CmdT IO ()
load_state [Char]
fname = do
    (State
state, StateSaveFile
save_file) <- [Char] -> CmdT IO (State, StateSaveFile)
read_state [Char]
fname
    StateSaveFile -> State -> CmdT IO ()
set_loaded_state StateSaveFile
save_file State
state

read_state :: FilePath -> Cmd.CmdT IO (Ui.State, StateSaveFile)
read_state :: [Char] -> CmdT IO (State, StateSaveFile)
read_state [Char]
fname = do
    let mkmsg :: a -> Text
mkmsg a
err = Text
"load " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
txt [Char]
fname forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty a
err
    Bool
writable <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO Bool
Files.writable [Char]
fname
    (State
state, Metric Seconds
metric) <- forall (m :: * -> *) a. MonadIO m => m a -> m (a, Metric Seconds)
Thread.timeAction forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) err a.
(Stack, M m) =>
(err -> Text) -> Either err a -> m a
Cmd.require_right forall a. Pretty a => a -> Text
mkmsg forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ([Char] -> IO (Either UnserializeError State)
read_state_ [Char]
fname)
    forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.notice forall a b. (a -> b) -> a -> b
$ Text
"read state from " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt [Char]
fname
        forall a. Semigroup a => a -> a -> a
<> (if Bool
writable then Text
" " else Text
" (ro) ")
        forall a. Semigroup a => a -> a -> a
<> State -> Text
Transform.short_stats State
state
        forall a. Semigroup a => a -> a -> a
<> Text
", took " forall a. Semigroup a => a -> a -> a
<> Metric Seconds -> Text
Thread.showMetric Metric Seconds
metric
    forall (m :: * -> *) a. Monad m => a -> m a
return (State
state, forall a. a -> Maybe a
Just
        (if Bool
writable then Writable
Cmd.ReadWrite else Writable
Cmd.ReadOnly, [Char] -> SaveFile
SaveState [Char]
fname))

-- | Low level 'read_state'.
read_state_ :: FilePath
    -> IO (Either Serialize.UnserializeError Ui.State)
read_state_ :: [Char] -> IO (Either UnserializeError State)
read_state_ = forall a.
Serialize a =>
Magic a -> [Char] -> IO (Either UnserializeError a)
Serialize.unserialize Magic State
Cmd.Serialize.score_magic

-- | Low level 'read_git'.
read_git_ :: SaveGit.Repo -> Maybe SaveGit.Commit
    -> IO (Either Text (Ui.State, SaveGit.Commit, [Text]))
read_git_ :: [Char] -> Maybe Commit -> IO (Either Text (State, Commit, [Text]))
read_git_ = [Char] -> Maybe Commit -> IO (Either Text (State, Commit, [Text]))
SaveGit.load


-- ** path

get_state_path :: Cmd.M m => m (Maybe FilePath)
get_state_path :: forall (m :: * -> *). M m => m (Maybe [Char])
get_state_path = do
    State
state <- forall (m :: * -> *). M m => m State
Cmd.get
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ SaveFile -> [Char]
make_state_path forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> State -> Maybe (Writable, SaveFile)
Cmd.state_save_file State
state

make_state_path :: Cmd.SaveFile -> FilePath
make_state_path :: SaveFile -> [Char]
make_state_path (Cmd.SaveState Canonical
fn) = Canonical -> [Char]
Path.to_path Canonical
fn
make_state_path (Cmd.SaveRepo Canonical
repo) = [Char] -> [Char]
state_path_for_repo (Canonical -> [Char]
Path.to_path Canonical
repo)

-- | Get a state save path based on a repo path.  This is for saving a backup
-- state, or when switching from SaveRepo to SaveState.
state_path_for_repo :: SaveGit.Repo -> FilePath
state_path_for_repo :: [Char] -> [Char]
state_path_for_repo [Char]
repo = [Char] -> [Char] -> [Char]
FilePath.replaceExtension [Char]
repo [Char]
".state"

-- | Figure out a path for a save state based on the namespace.
infer_state_path :: Id.Namespace -> Cmd.State -> FilePath
infer_state_path :: Namespace -> State -> [Char]
infer_state_path Namespace
ns State
state =
    State -> Relative -> [Char]
Cmd.to_absolute State
state Relative
Config.save_dir
        [Char] -> [Char] -> [Char]
</> Text -> [Char]
untxt (Namespace -> Text
Id.un_namespace Namespace
ns)
        [Char] -> [Char] -> [Char]
</> [Char]
default_state

default_state :: FilePath
default_state :: [Char]
default_state = [Char]
"save.state"

-- * git serialize

-- | Save a SavePoint to the git repo in 'Cmd.state_save_file', or start a new
-- one.  Set the 'Cmd.state_save_file' to the repo, so I'll keep saving to
-- that repo.
save_git :: Cmd.CmdT IO ()
save_git :: CmdT IO ()
save_git = [Char] -> CmdT IO ()
save_git_as forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). M m => m [Char]
get_git_path

save_git_as :: SaveGit.Repo -- ^ Save to this repo, or create it.
    -- 'Cmd.Undo.maintain_history' will start checkpointing to it.
    -- @.git@ is appended if it doesn't already have that suffix.
    -> Cmd.CmdT IO ()
save_git_as :: [Char] -> CmdT IO ()
save_git_as [Char]
repo = do
    [Char]
repo <- [Char] -> CmdT IO [Char]
expand_filename [Char]
repo
    [Char]
repo <- forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if [Char]
SaveGit.git_suffix forall a. Eq a => [a] -> [a] -> Bool
`List.isSuffixOf` [Char]
repo then [Char]
repo
        else [Char]
repo forall a. [a] -> [a] -> [a]
++ [Char]
SaveGit.git_suffix
    State
cmd_state <- forall (m :: * -> *). M m => m State
Cmd.get
    let rethrow :: Either Text a -> CmdT IO a
rethrow = forall (m :: * -> *) err a.
(Stack, M m) =>
(err -> Text) -> Either err a -> m a
Cmd.require_right ((Text
"save git " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
txt [Char]
repo forall a. Semigroup a => a -> a -> a
<> Text
": ") <>)
    Commit
commit <- case HistoryConfig -> Maybe Commit
Cmd.hist_last_commit forall a b. (a -> b) -> a -> b
$ State -> HistoryConfig
Cmd.state_history_config State
cmd_state of
        Just Commit
commit -> forall (m :: * -> *) a. Monad m => a -> m a
return Commit
commit
        Maybe Commit
Nothing -> 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
            State
state <- forall (m :: * -> *). M m => m State
Ui.get
            forall {a}. Either Text a -> CmdT IO a
rethrow forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (User -> [Char] -> SaveHistory -> IO (Either Text Commit)
SaveGit.checkpoint User
user [Char]
repo
                (State -> Maybe Commit -> [UiUpdate] -> [Text] -> SaveHistory
SaveGitT.SaveHistory State
state forall a. Maybe a
Nothing [] [Text
"save"]))
    SavePoint
save <- forall {a}. Either Text a -> CmdT IO a
rethrow forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ([Char] -> Commit -> IO (Either Text SavePoint)
SaveGit.set_save_tag [Char]
repo Commit
commit)
    forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.notice forall a b. (a -> b) -> a -> b
$ Text
"wrote save " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt SavePoint
save forall a. Semigroup a => a -> a -> a
<> Text
" to " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt [Char]
repo
    StateSaveFile -> SaveDirection -> CmdT IO ()
set_save_file (forall a. a -> Maybe a
Just (Writable
Cmd.ReadWrite, [Char] -> Commit -> Maybe [Text] -> SaveFile
SaveRepo [Char]
repo Commit
commit forall a. Maybe a
Nothing)) SaveDirection
Save

load_git :: FilePath -> Maybe SaveGit.Commit -> Cmd.CmdT IO ()
load_git :: [Char] -> Maybe Commit -> CmdT IO ()
load_git [Char]
repo Maybe Commit
maybe_commit = do
    (State
state, StateSaveFile
save_file) <- [Char] -> Maybe Commit -> CmdT IO (State, StateSaveFile)
read_git [Char]
repo Maybe Commit
maybe_commit
    StateSaveFile -> State -> CmdT IO ()
set_loaded_state StateSaveFile
save_file State
state

read_git :: FilePath -> Maybe SaveGit.Commit
    -> Cmd.CmdT IO (Ui.State, StateSaveFile)
read_git :: [Char] -> Maybe Commit -> CmdT IO (State, StateSaveFile)
read_git [Char]
repo Maybe Commit
maybe_commit = do
    (State
state, Commit
commit, [Text]
names) <- forall (m :: * -> *) err a.
(Stack, M m) =>
(err -> Text) -> Either err a -> m a
Cmd.require_right
        ((Text
"load git " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
txt [Char]
repo forall a. Semigroup a => a -> a -> a
<> Text
": ") <>)
        forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ([Char] -> Maybe Commit -> IO (Either Text (State, Commit, [Text]))
read_git_ [Char]
repo Maybe Commit
maybe_commit)
    Bool
writable <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO Bool
Files.writable [Char]
repo
    forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.notice forall a b. (a -> b) -> a -> b
$ Text
"read from " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt [Char]
repo forall a. Semigroup a => a -> a -> a
<> Text
", at " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Commit
commit
        forall a. Semigroup a => a -> a -> a
<> Text
" names: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt [Text]
names
        forall a. Semigroup a => a -> a -> a
<> if Bool
writable then Text
"" else Text
" (read-only, not setting save file)"
    forall (m :: * -> *) a. Monad m => a -> m a
return (State
state, forall a. a -> Maybe a
Just (if Bool
writable then Writable
Cmd.ReadWrite else Writable
Cmd.ReadOnly,
        [Char] -> Commit -> Maybe [Text] -> SaveFile
SaveRepo [Char]
repo Commit
commit (forall a. a -> Maybe a
Just [Text]
names)))

-- | Revert to given save point, or the last one.
revert :: Maybe String -> Cmd.CmdT IO ()
revert :: Maybe [Char] -> CmdT IO ()
revert Maybe [Char]
maybe_ref = do
    (Writable, SaveFile)
save_file <- forall (m :: * -> *) a. (Stack, M m) => Text -> Maybe a -> m a
Cmd.require Text
"can't revert when there is no save file"
        forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a. M m => (State -> a) -> m a
Cmd.gets State -> Maybe (Writable, SaveFile)
Cmd.state_save_file
    case (Writable, SaveFile)
save_file of
        (Writable
_, Cmd.SaveState Canonical
fn) -> do
            forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe [Char]
maybe_ref forall a b. (a -> b) -> a -> b
$ \[Char]
ref -> forall (m :: * -> *) a. (Stack, M m) => Text -> m a
Cmd.throw forall a b. (a -> b) -> a -> b
$
                Text
"can't revert to a commit when the save file isn't git: "
                forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
txt [Char]
ref
            [Char] -> CmdT IO ()
load (Canonical -> [Char]
Path.to_path Canonical
fn)
        (Writable
_, Cmd.SaveRepo Canonical
repo) -> [Char] -> CmdT IO ()
revert_git (Canonical -> [Char]
Path.to_path Canonical
repo)
    forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.notice forall a b. (a -> b) -> a -> b
$ Text
"revert to " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt (Writable, SaveFile)
save_file
    where
    revert_git :: [Char] -> CmdT IO ()
revert_git [Char]
repo = do
        SavePoint
save <- case Maybe [Char]
maybe_ref of
            Maybe [Char]
Nothing -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. (Stack, M m) => Text -> Maybe a -> m a
Cmd.require Text
"no last save"
                forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ([Char] -> Maybe Commit -> IO (Maybe (SavePoint, Commit))
SaveGit.read_last_save [Char]
repo forall a. Maybe a
Nothing)
            Just [Char]
ref -> forall (m :: * -> *) a. (Stack, M m) => Text -> Maybe a -> m a
Cmd.require (Text
"unparseable SavePoint: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt [Char]
ref)
                ([Char] -> Maybe SavePoint
SaveGit.ref_to_save [Char]
ref)
        Commit
commit <- forall (m :: * -> *) a. (Stack, M m) => Text -> Maybe a -> m a
Cmd.require (Text
"save ref not found: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt SavePoint
save)
            forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. Text -> IO a -> CmdT IO a
rethrow_git Text
"revert" ([Char] -> SavePoint -> IO (Maybe Commit)
SaveGit.read_save_ref [Char]
repo SavePoint
save)
        [Char] -> Maybe Commit -> CmdT IO ()
load_git [Char]
repo (forall a. a -> Maybe a
Just Commit
commit)

rethrow_git :: Text -> IO a -> Cmd.CmdT IO a
rethrow_git :: forall a. Text -> IO a -> CmdT IO a
rethrow_git Text
caller IO a
io = forall (m :: * -> *) err a.
(Stack, M m) =>
(err -> Text) -> Either err a -> m a
Cmd.require_right forall a. a -> a
id forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a. Text -> IO a -> IO (Either Text a)
SaveGit.try Text
caller IO a
io)

rethrow_io :: Text -> IO a -> Cmd.CmdT IO a
rethrow_io :: forall a. Text -> IO a -> CmdT IO a
rethrow_io Text
caller IO a
io = forall (m :: * -> *) err a.
(Stack, M m) =>
(err -> Text) -> Either err a -> m a
Cmd.require_right
    (\IOException
exc -> Text
caller forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt (IOException
exc :: Exception.IOException))
        forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall e a. Exception e => IO a -> IO (Either e a)
Exception.try IO a
io)

-- ** path

get_git_path :: Cmd.M m => m Git.Repo
get_git_path :: forall (m :: * -> *). M m => m [Char]
get_git_path = do
    Namespace
ns <- forall (m :: * -> *). M m => m Namespace
Ui.get_namespace
    State
state <- forall (m :: * -> *). M m => m State
Cmd.get
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Namespace -> State -> [Char]
make_git_path Namespace
ns State
state

make_git_path :: Id.Namespace -> Cmd.State -> Git.Repo
make_git_path :: Namespace -> State -> [Char]
make_git_path Namespace
ns State
state = case State -> Maybe (Writable, SaveFile)
Cmd.state_save_file State
state of
    Maybe (Writable, SaveFile)
Nothing -> State -> Relative -> [Char]
Cmd.to_absolute State
state Relative
Config.save_dir
        [Char] -> [Char] -> [Char]
</> Text -> [Char]
untxt (Namespace -> Text
Id.un_namespace Namespace
ns) [Char] -> [Char] -> [Char]
</> [Char]
default_git
    Just (Writable
_, Cmd.SaveState Canonical
fn) ->
        [Char] -> [Char] -> [Char]
FilePath.replaceExtension (Canonical -> [Char]
Path.to_path Canonical
fn) [Char]
SaveGit.git_suffix
    Just (Writable
_, Cmd.SaveRepo Canonical
repo) -> Canonical -> [Char]
Path.to_path Canonical
repo

default_git :: FilePath
default_git :: [Char]
default_git = [Char]
"save" forall a. [a] -> [a] -> [a]
++ [Char]
SaveGit.git_suffix

-- * config

save_allocations :: FilePath -> Cmd.CmdT IO ()
save_allocations :: [Char] -> CmdT IO ()
save_allocations [Char]
fname = do
    Allocations
allocs <- Lens State Config
Ui.configforall a b c. Lens a b -> Lens b c -> Lens a c
#Config :-> Allocations
UiConfig.allocations forall (f :: * -> *) a b. Functor f => Lens a b -> f a -> f b
<#> forall (m :: * -> *). M m => m State
Ui.get
    [Char]
fname <- [Char] -> CmdT IO [Char]
expand_filename [Char]
fname
    forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.notice forall a b. (a -> b) -> a -> b
$ Text
"write instrument allocations to " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt [Char]
fname
    forall a. Text -> IO a -> CmdT IO a
rethrow_io Text
"save_allocations" forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$
        forall a. Serialize a => Magic a -> [Char] -> a -> IO Bool
Serialize.serialize Magic Allocations
Cmd.Serialize.allocations_magic [Char]
fname Allocations
allocs

load_allocations :: FilePath -> Cmd.CmdT IO UiConfig.Allocations
load_allocations :: [Char] -> CmdT IO Allocations
load_allocations [Char]
fname = do
    [Char]
fname <- [Char] -> CmdT IO [Char]
expand_filename [Char]
fname
    forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.notice forall a b. (a -> b) -> a -> b
$ Text
"load instrument allocations from " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt [Char]
fname
    let mkmsg :: a -> Text
mkmsg a
err = Text
"unserializing instrument allocations " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt [Char]
fname
            forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty a
err
    forall (m :: * -> *) err a.
(Stack, M m) =>
(err -> Text) -> Either err a -> m a
Cmd.require_right forall a. Pretty a => a -> Text
mkmsg
        forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a.
Serialize a =>
Magic a -> [Char] -> IO (Either UnserializeError a)
Serialize.unserialize Magic Allocations
Cmd.Serialize.allocations_magic [Char]
fname)

-- * misc

-- | Git repos don't checkpoint views, but because I'm accustomed to them
-- checkpointing everything else I expect the views to always be saved.
--
-- So call this when quitting or switching away from a save file to save the
-- views.
--
-- They could theoretically checkpoint view changes, but it would be
-- complicated (they mostly come from the GUI, not diff) and inefficient
-- (scrolling emits tons of them).
save_views :: Cmd.State -> Ui.State -> IO ()
save_views :: State -> State -> IO ()
save_views State
cmd_state State
ui_state = case State -> Maybe (Writable, SaveFile)
Cmd.state_save_file State
cmd_state of
    Just (Writable
Cmd.ReadWrite, Cmd.SaveRepo Canonical
repo) ->
        [Char] -> Map ViewId View -> IO ()
SaveGit.save_views (Canonical -> [Char]
Path.to_path Canonical
repo) forall a b. (a -> b) -> a -> b
$ State -> Map ViewId View
Ui.state_views State
ui_state
    Maybe (Writable, SaveFile)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | This is just like 'Cmd.SaveFile', except SaveRepo has more data.
data SaveFile =
    SaveState !FilePath
    -- | The Strings are the cmd name of this commit, and only set on a git
    -- load.
    | SaveRepo !SaveGit.Repo !SaveGit.Commit !(Maybe [Text])
    deriving (Int -> SaveFile -> [Char] -> [Char]
[SaveFile] -> [Char] -> [Char]
SaveFile -> [Char]
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [SaveFile] -> [Char] -> [Char]
$cshowList :: [SaveFile] -> [Char] -> [Char]
show :: SaveFile -> [Char]
$cshow :: SaveFile -> [Char]
showsPrec :: Int -> SaveFile -> [Char] -> [Char]
$cshowsPrec :: Int -> SaveFile -> [Char] -> [Char]
Show)
type StateSaveFile = Maybe (Cmd.Writable, SaveFile)

data SaveDirection = Save | Load deriving (Int -> SaveDirection -> [Char] -> [Char]
[SaveDirection] -> [Char] -> [Char]
SaveDirection -> [Char]
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [SaveDirection] -> [Char] -> [Char]
$cshowList :: [SaveDirection] -> [Char] -> [Char]
show :: SaveDirection -> [Char]
$cshow :: SaveDirection -> [Char]
showsPrec :: Int -> SaveDirection -> [Char] -> [Char]
$cshowsPrec :: Int -> SaveDirection -> [Char] -> [Char]
Show)

-- | Do the necessary housekeeping after loading a new Ui.State.
set_loaded_state :: StateSaveFile -> Ui.State -> Cmd.CmdT IO ()
set_loaded_state :: StateSaveFile -> State -> CmdT IO ()
set_loaded_state StateSaveFile
save_file State
state = do
    StateSaveFile -> SaveDirection -> CmdT IO ()
set_save_file StateSaveFile
save_file SaveDirection
Load
    CmdT IO Status
Play.cmd_stop
    forall (m :: * -> *). M m => (State -> State) -> m ()
Cmd.modify forall a b. (a -> b) -> a -> b
$ HistoryEntry -> State -> State
Cmd.reinit_state (State -> HistoryEntry
Cmd.empty_history_entry State
state)
    -- Names is only set on a git load.  This will cause "Cmd.Undo" to clear
    -- out the history.
    case StateSaveFile
save_file of
        Just (Writable
_, SaveRepo [Char]
_ Commit
commit (Just [Text]
names)) -> 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 = (State -> History
Cmd.state_history State
st)
                { hist_last_cmd :: Maybe LastCmd
Cmd.hist_last_cmd = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Maybe Commit -> [Text] -> LastCmd
Cmd.Load (forall a. a -> Maybe a
Just Commit
commit) [Text]
names }
            }
        StateSaveFile
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    State
old <- forall (m :: * -> *). M m => m State
Ui.get
    forall (m :: * -> *). M m => State -> m ()
Ui.put forall a b. (a -> b) -> a -> b
$ State -> State
Ui.clear forall a b. (a -> b) -> a -> b
$
        Namespace -> State -> State -> State
Transform.replace_namespace Namespace
Clip.clip_namespace State
old State
state
    Maybe ViewId
root <- case Config -> Maybe BlockId
UiConfig.config_root (State -> Config
Ui.state_config State
state) of
        Maybe BlockId
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
        Just BlockId
root -> forall a. [a] -> Maybe a
Lists.head forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [k]
Map.keys forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => BlockId -> m (Map ViewId View)
Ui.views_of BlockId
root
    -- Try to focus on the root block, for consistency.
    let focused :: Maybe ViewId
focused = forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum [Maybe ViewId
root, forall a. [a] -> Maybe a
Lists.head forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [k]
Map.keys (State -> Map ViewId View
Ui.state_views State
state)]
    forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe ViewId
focused forall (m :: * -> *). M m => ViewId -> m ()
Cmd.focus

-- | If I switch away from a repo (either to another repo or to a plain state),
-- I have to clear out all the remains of the old repo, since its Commits are
-- no longer valid.
--
-- It's really important to call this whenever you change
-- 'Cmd.state_save_file'!
set_save_file :: StateSaveFile -> SaveDirection -> Cmd.CmdT IO ()
set_save_file :: StateSaveFile -> SaveDirection -> CmdT IO ()
set_save_file StateSaveFile
save_file SaveDirection
direction = do
    (Maybe Commit
maybe_commit, Maybe (Writable, SaveFile)
file) <- case StateSaveFile
save_file of
        StateSaveFile
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Maybe a
Nothing, forall a. Maybe a
Nothing)
        Just (Writable
writable, SaveFile
save) -> case SaveFile
save of
            SaveState [Char]
fname -> do
                Canonical
path <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO Canonical
Path.canonical [Char]
fname
                forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Maybe a
Nothing, forall a. a -> Maybe a
Just (Writable
writable, Canonical -> SaveFile
Cmd.SaveState Canonical
path))
            SaveRepo [Char]
repo Commit
commit Maybe [Text]
_ -> do
                Canonical
path <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO Canonical
Path.canonical [Char]
repo
                forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just Commit
commit, forall a. a -> Maybe a
Just (Writable
writable, Canonical -> SaveFile
Cmd.SaveRepo Canonical
path))
    State
cmd_state <- forall (m :: * -> *). M m => m State
Cmd.get
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe (Writable, SaveFile)
file forall a. Eq a => a -> a -> Bool
/= State -> Maybe (Writable, SaveFile)
Cmd.state_save_file State
cmd_state) forall a b. (a -> b) -> a -> b
$ do
        State
ui_state <- forall (m :: * -> *). M m => m State
Ui.get
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ State -> State -> IO ()
save_views State
cmd_state State
ui_state
        forall (m :: * -> *). M m => (State -> State) -> m ()
Cmd.modify forall a b. (a -> b) -> a -> b
$ \State
state -> State
state
            { state_save_file :: Maybe (Writable, SaveFile)
Cmd.state_save_file = Maybe (Writable, SaveFile)
file
            , state_history :: History
Cmd.state_history = let hist :: History
hist = State -> History
Cmd.state_history State
state in History
hist
                { hist_past :: [HistoryEntry]
Cmd.hist_past = case SaveDirection
direction of
                    SaveDirection
Load -> []
                    SaveDirection
Save -> forall a b. (a -> b) -> [a] -> [b]
map HistoryEntry -> HistoryEntry
clear (History -> [HistoryEntry]
Cmd.hist_past History
hist)
                , hist_present :: HistoryEntry
Cmd.hist_present = (History -> HistoryEntry
Cmd.hist_present History
hist)
                    { hist_commit :: Maybe Commit
Cmd.hist_commit = Maybe Commit
maybe_commit }
                , hist_future :: [HistoryEntry]
Cmd.hist_future = []
                }
            , state_history_config :: HistoryConfig
Cmd.state_history_config = (State -> HistoryConfig
Cmd.state_history_config State
state)
                { hist_last_commit :: Maybe Commit
Cmd.hist_last_commit = Maybe Commit
maybe_commit }
            }
    -- This is called both when saving and loading, so it's a good place to
    -- mark that the state is synced to disk.
    forall (m :: * -> *). M m => (State -> State) -> m ()
Cmd.modify forall a b. (a -> b) -> a -> b
$ \State
st -> State
st
        { state_saved :: Saved
Cmd.state_saved = (State -> Saved
Cmd.state_saved State
st)
            { _saved_state :: SavedState
Cmd._saved_state = case SaveDirection
direction of
                SaveDirection
Load -> SavedState
Cmd.JustLoaded
                SaveDirection
Save -> SavedState
Cmd.SavedChanges
            }
        }
    where
    clear :: HistoryEntry -> HistoryEntry
clear HistoryEntry
entry = HistoryEntry
entry { hist_commit :: Maybe Commit
Cmd.hist_commit = forall a. Maybe a
Nothing }