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

{-# LANGUAGE CPP #-}
module Cmd.SaveGit (
    SaveHistory(..), LoadHistory(..), Repo, Commit
    -- * save point
    , is_git, git_suffix
    , SavePoint, set_save_tag, write_save_ref, read_save_ref
    , read_last_save, ref_to_save
    -- * save
    , checkpoint, save, should_record
    -- * load
    , load, load_previous_history, load_next_history
    -- * views
    , save_views, load_views
    -- * util
    , infer_commit, try
    -- * User
    , get_user
#ifdef TESTING
    , parse_names, load_from
#endif
) where
import qualified Control.Exception as Exception
import           Data.ByteString (ByteString)
import qualified Data.Char as Char
import qualified Data.Either as Either
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Maybe as Maybe
import qualified Data.Set as Set
import qualified Data.Text as Text

import qualified GHC.Float as Float
import qualified Numeric
import qualified System.FilePath as FilePath
import           System.FilePath ((</>))
import qualified System.IO.Error as IO.Error
import qualified System.Process as Process

import qualified Util.Files as Files
import qualified Util.Git as Git
import           Util.GitT (Commit, Repo)
import qualified Util.Lists as Lists
import qualified Util.Log as Log
import qualified Util.Serialize as Serialize

import qualified Cmd.SaveGitT as SaveGitT
import           Cmd.SaveGitT (SaveHistory(..))
import qualified Cmd.Serialize

import qualified Ui.Block as Block
import qualified Ui.Diff as Diff
import qualified Ui.Events as Events
import qualified Ui.Id as Id
import qualified Ui.ScoreTime as ScoreTime
import qualified Ui.Track as Track
import qualified Ui.Ui as Ui
import qualified Ui.Update as Update

import           Global
import           Types


-- | History loaded from disk.  It only has CmdUpdates so you can feed them to
-- diff.
data LoadHistory = LoadHistory !Ui.State !Commit !Update.UiDamage ![Text]
    deriving (Int -> LoadHistory -> ShowS
[LoadHistory] -> ShowS
LoadHistory -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [LoadHistory] -> ShowS
$cshowList :: [LoadHistory] -> ShowS
show :: LoadHistory -> [Char]
$cshow :: LoadHistory -> [Char]
showsPrec :: Int -> LoadHistory -> ShowS
$cshowsPrec :: Int -> LoadHistory -> ShowS
Show)

is_git :: FilePath -> Bool
is_git :: [Char] -> Bool
is_git = ([Char]
git_suffix `List.isSuffixOf`)

git_suffix :: FilePath
git_suffix :: [Char]
git_suffix = [Char]
".git"

-- * save point

-- | Add a new save point tag to the given commit, unless it already has one.
set_save_tag :: Git.Repo -> Commit -> IO (Either Text SavePoint)
set_save_tag :: [Char] -> Commit -> IO (Either Text SavePoint)
set_save_tag [Char]
repo Commit
commit = forall a. Text -> IO a -> IO (Either Text a)
try Text
"set_save_tag" forall a b. (a -> b) -> a -> b
$ do
    [Char] -> IO ()
Git.gc [Char]
repo -- Might as well clean things up at this point.
    [Char] -> Maybe Commit -> IO (Maybe (SavePoint, Commit))
read_last_save [Char]
repo (forall a. a -> Maybe a
Just Commit
commit) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe (SavePoint, Commit)
Nothing -> do
            SavePoint
save <- [Char] -> SavePoint -> IO SavePoint
find_next_save [Char]
repo ([Int] -> SavePoint
SavePoint [])
            [Char] -> SavePoint -> Commit -> IO ()
write_save_ref [Char]
repo SavePoint
save Commit
commit
            forall (m :: * -> *) a. Monad m => a -> m a
return SavePoint
save
        Just (SavePoint
last_save, Commit
save_commit) -> do
            SavePoint
save <- [Char] -> SavePoint -> IO SavePoint
find_next_save [Char]
repo SavePoint
last_save
            if Commit
commit forall a. Eq a => a -> a -> Bool
== Commit
save_commit then forall (m :: * -> *) a. Monad m => a -> m a
return SavePoint
last_save
                else [Char] -> SavePoint -> Commit -> IO ()
write_save_ref [Char]
repo SavePoint
save Commit
commit forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return SavePoint
save

-- | Stored in reverse order as in the ref name.
newtype SavePoint = SavePoint [Int] deriving (SavePoint -> SavePoint -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SavePoint -> SavePoint -> Bool
$c/= :: SavePoint -> SavePoint -> Bool
== :: SavePoint -> SavePoint -> Bool
$c== :: SavePoint -> SavePoint -> Bool
Eq, Int -> SavePoint -> ShowS
[SavePoint] -> ShowS
SavePoint -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [SavePoint] -> ShowS
$cshowList :: [SavePoint] -> ShowS
show :: SavePoint -> [Char]
$cshow :: SavePoint -> [Char]
showsPrec :: Int -> SavePoint -> ShowS
$cshowsPrec :: Int -> SavePoint -> ShowS
Show, [SavePoint] -> Doc
SavePoint -> Text
SavePoint -> Doc
forall a. (a -> Text) -> (a -> Doc) -> ([a] -> Doc) -> Pretty a
formatList :: [SavePoint] -> Doc
$cformatList :: [SavePoint] -> Doc
format :: SavePoint -> Doc
$cformat :: SavePoint -> Doc
pretty :: SavePoint -> Text
$cpretty :: SavePoint -> Text
Pretty)

-- | Create a tag for the given commit.
write_save_ref :: Git.Repo -> SavePoint -> Commit -> IO ()
write_save_ref :: [Char] -> SavePoint -> Commit -> IO ()
write_save_ref [Char]
repo SavePoint
save Commit
commit = [Char] -> Commit -> [Char] -> IO ()
Git.write_ref [Char]
repo Commit
commit (SavePoint -> [Char]
save_to_ref SavePoint
save)

read_save_ref :: Git.Repo -> SavePoint -> IO (Maybe Commit)
read_save_ref :: [Char] -> SavePoint -> IO (Maybe Commit)
read_save_ref [Char]
repo SavePoint
save = [Char] -> [Char] -> IO (Maybe Commit)
Git.read_ref [Char]
repo (SavePoint -> [Char]
save_to_ref SavePoint
save)

read_last_save :: Git.Repo -> Maybe Commit
    -- ^ Find the last save from this commit, or HEAD if not given.
    -> IO (Maybe (SavePoint, Commit))
read_last_save :: [Char] -> Maybe Commit -> IO (Maybe (SavePoint, Commit))
read_last_save [Char]
repo Maybe Commit
maybe_commit = do
    -- This may be called on incomplete repos without a HEAD.
    Maybe [Commit]
maybe_commits <- forall a. IO a -> IO (Maybe a)
catch forall a b. (a -> b) -> a -> b
$
        forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Char] -> IO [Commit]
Git.read_log_head [Char]
repo) ([Char] -> Commit -> IO [Commit]
Git.read_log_from [Char]
repo) Maybe Commit
maybe_commit
    let commits :: [Commit]
commits = forall a. a -> Maybe a -> a
fromMaybe [] Maybe [Commit]
maybe_commits
    Map [Char] Commit
refs <- [Char] -> IO (Map [Char] Commit)
Git.read_ref_map [Char]
repo
    let commit_to_save :: Map Commit SavePoint
commit_to_save = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ do
            ([Char]
ref, Commit
commit) <- forall k a. Map k a -> [(k, a)]
Map.toList Map [Char] Commit
refs
            Just SavePoint
save <- forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe SavePoint
ref_to_save [Char]
ref
            forall (m :: * -> *) a. Monad m => a -> m a
return (Commit
commit, SavePoint
save)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Maybe a
Lists.head [(SavePoint
save, Commit
commit) | (Just SavePoint
save, Commit
commit)
        <- forall a b. [a] -> [b] -> [(a, b)]
zip (forall a b. (a -> b) -> [a] -> [b]
map (forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map Commit SavePoint
commit_to_save) [Commit]
commits) [Commit]
commits]

-- | Find the SavePoint that should be added after the given SavePoint.
find_next_save :: Git.Repo -> SavePoint -> IO SavePoint
find_next_save :: [Char] -> SavePoint -> IO SavePoint
find_next_save [Char]
repo SavePoint
save =
    forall {a}. Maybe a -> IO a
from_just forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a.
Monad m =>
(a -> m Bool) -> [a] -> m (Maybe a)
findM SavePoint -> IO Bool
save_free (forall a. (a -> a) -> a -> [a]
iterate SavePoint -> SavePoint
split (SavePoint -> SavePoint
increment SavePoint
save))
    where
    save_free :: SavePoint -> IO Bool
save_free SavePoint
save = forall a. Maybe a -> Bool
Maybe.isNothing forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> [Char] -> IO (Maybe Commit)
Git.read_ref [Char]
repo (SavePoint -> [Char]
save_to_ref SavePoint
save)
    from_just :: Maybe a -> IO a
from_just = forall b a. b -> (a -> b) -> Maybe a -> b
maybe -- This should never happen since iterate tries forever.
        (forall a. [Char] -> IO a
Git.throw forall a b. (a -> b) -> a -> b
$ [Char]
"couldn't find a free save name after " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show SavePoint
save)
        forall (m :: * -> *) a. Monad m => a -> m a
return
    split :: SavePoint -> SavePoint
split (SavePoint [Int]
xs) = [Int] -> SavePoint
SavePoint (Int
0 forall a. a -> [a] -> [a]
: [Int]
xs)
    increment :: SavePoint -> SavePoint
increment (SavePoint []) = [Int] -> SavePoint
SavePoint [Int
0]
    increment (SavePoint (Int
x:[Int]
xs)) = [Int] -> SavePoint
SavePoint (Int
x forall a. Num a => a -> a -> a
+ Int
1 forall a. a -> [a] -> [a]
: [Int]
xs)

ref_to_save :: Git.Ref -> Maybe SavePoint
ref_to_save :: [Char] -> Maybe SavePoint
ref_to_save [Char]
ref
    | Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
Char.isDigit) [[Char]]
versions) = forall a. Maybe a
Nothing
    | Bool
otherwise = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [Int] -> SavePoint
SavePoint (forall a. [a] -> [a]
reverse (forall a b. (a -> b) -> [a] -> [b]
map forall a. Read a => [Char] -> a
read [[Char]]
versions))
    where
    ([Char]
save, Bool
_) = forall a. Eq a => [a] -> [a] -> ([a], Bool)
Lists.dropPrefix [Char]
"tags/" [Char]
ref
    versions :: [[Char]]
versions = forall a. Eq a => NonNull a -> NonNull a -> NonNull (NonNull a)
Lists.split [Char]
"." [Char]
save

save_to_ref :: SavePoint -> Git.Ref
save_to_ref :: SavePoint -> [Char]
save_to_ref (SavePoint [Int]
versions) =
    [Char]
"tags" [Char] -> ShowS
</> forall a. Monoid a => a -> [a] -> a
Lists.join [Char]
"." (forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> [Char]
show (forall a. [a] -> [a]
reverse [Int]
versions))


-- * save

-- | Checkpoint the given SaveHistory.  If it has no previous commit, create
-- a new repo.
checkpoint :: SaveGitT.User -> Git.Repo -> SaveHistory
    -> IO (Either Text Commit)
checkpoint :: User -> [Char] -> SaveHistory -> IO (Either Text Commit)
checkpoint User
user [Char]
repo (SaveHistory State
state Maybe Commit
Nothing [UiUpdate]
_ [Text]
names) =
    forall a. Text -> IO a -> IO (Either Text a)
try Text
"save" forall a b. (a -> b) -> a -> b
$ User -> [Char] -> State -> [Text] -> IO Commit
save User
user [Char]
repo State
state [Text]
names
checkpoint User
user [Char]
repo (SaveHistory State
state (Just Commit
commit) [UiUpdate]
updates [Text]
names) =
        forall a. Text -> IO a -> IO (Either Text a)
try Text
"checkpoint" forall a b. (a -> b) -> a -> b
$ do
    let ([Text]
not_found, [Modification]
mods) = Bool -> State -> [UiUpdate] -> ([Text], [Modification])
dump_diff Bool
False State
state (forall a. (a -> Bool) -> [a] -> [a]
filter UiUpdate -> Bool
should_record [UiUpdate]
updates)
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
not_found) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.warn forall a b. (a -> b) -> a -> b
$ Text
"ignored updates for nonexistent "
            forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
", " [Text]
not_found
            forall a. Semigroup a => a -> a -> a
<> Text
"; this probably means 'Ui.Diff.cancel_updates didn't do its job"
    if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Modification]
mods then forall (m :: * -> *) a. Monad m => a -> m a
return Commit
commit else do
        forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM ([Char] -> IO Bool
Files.writable [Char]
repo) forall a b. (a -> b) -> a -> b
$
            forall a. [Char] -> IO a
Git.throw forall a b. (a -> b) -> a -> b
$ [Char]
"git repo is not writable: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show [Char]
repo
        Tree
last_tree <- CommitData -> Tree
Git.commit_tree forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> Commit -> IO CommitData
Git.read_commit [Char]
repo Commit
commit
        Tree
tree <- [Char] -> Tree -> [Modification] -> IO Tree
Git.modify_tree [Char]
repo Tree
last_tree [Modification]
mods
        User -> [Char] -> Tree -> Maybe Commit -> [Char] -> IO Commit
commit_tree User
user [Char]
repo Tree
tree (forall a. a -> Maybe a
Just Commit
commit)
            ([Char] -> [Text] -> [Char]
unparse_names [Char]
"checkpoint" [Text]
names)

-- | Create a new repo, or throw if it already exists.
save :: SaveGitT.User -> Git.Repo -> Ui.State -> [Text] -> IO Commit
save :: User -> [Char] -> State -> [Text] -> IO Commit
save User
user [Char]
repo State
state [Text]
cmd_names = do
    forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM ([Char] -> IO Bool
Git.init [Char]
repo) forall a b. (a -> b) -> a -> b
$
        forall a. [Char] -> IO a
Git.throw [Char]
"refusing to overwrite a repo that already exists"
    Dir
dir <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. [Char] -> IO a
Git.throw forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
"make_dir: "<>)) forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
        [([Char], ByteString)] -> Either [Char] Dir
Git.make_dir (State -> [([Char], ByteString)]
dump State
state)
    Tree
tree <- [Char] -> Dir -> IO Tree
Git.write_dir [Char]
repo Dir
dir
    User -> [Char] -> Tree -> Maybe Commit -> [Char] -> IO Commit
commit_tree User
user [Char]
repo Tree
tree forall a. Maybe a
Nothing ([Char] -> [Text] -> [Char]
unparse_names [Char]
"save" [Text]
cmd_names)

-- | True if this update is interesting enough to record a checkpoint for.
should_record :: Update.UiUpdate -> Bool
should_record :: UiUpdate -> Bool
should_record = \case
    -- BlockConfig changes are only box colors, which I never need to save.
    Update.Block BlockId
_ (Update.BlockConfig {}) -> Bool
False
    UiUpdate
update -> Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ UiUpdate -> Bool
Update.is_view_update UiUpdate
update

commit_tree :: SaveGitT.User -> Git.Repo -> Git.Tree -> Maybe Commit -> String
    -> IO Commit
commit_tree :: User -> [Char] -> Tree -> Maybe Commit -> [Char] -> IO Commit
commit_tree User
user [Char]
repo Tree
tree Maybe Commit
maybe_parent [Char]
desc = do
    Commit
commit <- [Char] -> Text -> Text -> [Commit] -> Tree -> [Char] -> IO Commit
Git.write_commit [Char]
repo (User -> Text
SaveGitT.name User
user) (User -> Text
SaveGitT.email User
user)
        (forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (forall a. a -> [a] -> [a]
:[]) Maybe Commit
maybe_parent) Tree
tree [Char]
desc
    [Char] -> Commit -> IO ()
Git.update_head [Char]
repo Commit
commit
    forall (m :: * -> *) a. Monad m => a -> m a
return Commit
commit

-- ** events update

-- | TODO disabled event because loading isn't implemented.  Should probably
-- just delete it all.
dump_events :: Ui.State -> TrackId -> ScoreTime -> ScoreTime
    -> Git.Modification
dump_events :: State -> TrackId -> ScoreTime -> ScoreTime -> Modification
dump_events State
state TrackId
track_id ScoreTime
start ScoreTime
end =
    [Char] -> ByteString -> Modification
Git.Add (TrackId -> ScoreTime -> ScoreTime -> [Char]
events_path TrackId
track_id ScoreTime
start ScoreTime
end) forall a b. (a -> b) -> a -> b
$
        forall a. Serialize a => a -> ByteString
Serialize.encode forall a b. (a -> b) -> a -> b
$ TrackId -> ScoreTime -> ScoreTime -> Events -> EventsUpdate
EventsUpdate TrackId
track_id ScoreTime
start ScoreTime
end Events
events
    where
    events :: Events
events = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Events
Events.empty
        (Range -> Events -> Events
Events.in_range (ScoreTime -> ScoreTime -> Range
Events.Range ScoreTime
start ScoreTime
end) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Track -> Events
Track.track_events)
        (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TrackId
track_id (State -> Map TrackId Track
Ui.state_tracks State
state))

-- | Put the range into the filename.  You still have to load all the event
-- files in the directory, but at least exactly matching ranges will overwrite
-- each other.
events_path :: TrackId -> ScoreTime -> ScoreTime -> String
events_path :: TrackId -> ScoreTime -> ScoreTime -> [Char]
events_path TrackId
track_id ScoreTime
start ScoreTime
end = forall id. Ident id => id -> [Char]
id_to_path TrackId
track_id forall a. [a] -> [a] -> [a]
++ [Char]
"_"
    [Char] -> ShowS
</> ScoreTime -> [Char]
score_to_hex ScoreTime
start forall a. [a] -> [a] -> [a]
++ [Char]
"-" forall a. [a] -> [a] -> [a]
++ ScoreTime -> [Char]
score_to_hex ScoreTime
end

data EventsUpdate = EventsUpdate TrackId ScoreTime ScoreTime Events.Events
    deriving (Int -> EventsUpdate -> ShowS
[EventsUpdate] -> ShowS
EventsUpdate -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [EventsUpdate] -> ShowS
$cshowList :: [EventsUpdate] -> ShowS
show :: EventsUpdate -> [Char]
$cshow :: EventsUpdate -> [Char]
showsPrec :: Int -> EventsUpdate -> ShowS
$cshowsPrec :: Int -> EventsUpdate -> ShowS
Show)

instance Serialize.Serialize EventsUpdate where
    put :: Putter EventsUpdate
put (EventsUpdate TrackId
a ScoreTime
b ScoreTime
c Events
d) = forall a. Serialize a => Putter a
Serialize.put TrackId
a forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Serialize a => Putter a
Serialize.put ScoreTime
b
        forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Serialize a => Putter a
Serialize.put ScoreTime
c forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Serialize a => Putter a
Serialize.put Events
d
    get :: Get EventsUpdate
get = TrackId -> ScoreTime -> ScoreTime -> Events -> EventsUpdate
EventsUpdate forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Serialize a => Get a
Serialize.get forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Serialize a => Get a
Serialize.get forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Serialize a => Get a
Serialize.get
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Serialize a => Get a
Serialize.get

score_to_hex :: ScoreTime -> String
score_to_hex :: ScoreTime -> [Char]
score_to_hex = ShowS
pad forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. (Integral a, Show a) => a -> ShowS
Numeric.showHex [Char]
"" forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Word64
Float.castDoubleToWord64
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScoreTime -> Double
ScoreTime.to_double
    where pad :: ShowS
pad [Char]
s = forall a. Int -> a -> [a]
replicate (Int
16 forall a. Num a => a -> a -> a
- forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
s) Char
'0' forall a. [a] -> [a] -> [a]
++ [Char]
s


-- * load

load :: Git.Repo -> Maybe Commit
    -> IO (Either Text (Ui.State, Commit, [Text]))
    -- ^ (state, commit, name of the cmd this is a checkpoint of)
load :: [Char] -> Maybe Commit -> IO (Either Text (State, Commit, [Text]))
load [Char]
repo Maybe Commit
maybe_commit = forall a. Text -> IO (Either Text a) -> IO (Either Text a)
try_e Text
"load" forall a b. (a -> b) -> a -> b
$ do
    -- TODO have to handle both compact and expanded tracks
    Commit
commit <- [Char] -> Maybe Commit -> IO Commit
default_head [Char]
repo Maybe Commit
maybe_commit
    CommitData
commit_data <- [Char] -> Commit -> IO CommitData
Git.read_commit [Char]
repo Commit
commit
    Dir
dirs <- [Char] -> Tree -> IO Dir
Git.read_dir [Char]
repo (CommitData -> Tree
Git.commit_tree CommitData
commit_data)
    [Text]
names <- [Char] -> IO [Text]
parse_names (CommitData -> [Char]
Git.commit_text CommitData
commit_data)
    Either Text (Map ViewId View)
either_views <- [Char] -> IO (Either Text (Map ViewId View))
load_views [Char]
repo
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ do
        State
state <- Dir -> Either Text State
undump Dir
dirs
        Map ViewId View
views <- forall a. Text -> Either Text a -> Either Text a
with_msg Text
"views" Either Text (Map ViewId View)
either_views
        forall (m :: * -> *) a. Monad m => a -> m a
return (State
state { state_views :: Map ViewId View
Ui.state_views = Map ViewId View
views }, Commit
commit, [Text]
names)

-- | Try to go get the previous history entry.
load_previous_history :: Git.Repo -> Ui.State -> Commit
    -> IO (Either Text (Maybe LoadHistory))
load_previous_history :: [Char] -> State -> Commit -> IO (Either Text (Maybe LoadHistory))
load_previous_history [Char]
repo State
state Commit
commit = forall a. Text -> IO (Either Text a) -> IO (Either Text a)
try_e Text
"load_previous_history" forall a b. (a -> b) -> a -> b
$ do
    CommitData
commit_data <- [Char] -> Commit -> IO CommitData
Git.read_commit [Char]
repo Commit
commit
    case forall a. [a] -> Maybe a
Lists.head (CommitData -> [Commit]
Git.commit_parents CommitData
commit_data) of
        Maybe Commit
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a. Maybe a
Nothing
        Just Commit
parent -> [Char]
-> State
-> Commit
-> Commit
-> IO (Either Text (Maybe LoadHistory))
load_history [Char]
repo State
state Commit
commit Commit
parent

-- | Try to a commits that has this one as a parent.
load_next_history :: Git.Repo -> Ui.State -> Commit
    -> IO (Either Text (Maybe LoadHistory))
load_next_history :: [Char] -> State -> Commit -> IO (Either Text (Maybe LoadHistory))
load_next_history [Char]
repo State
state Commit
commit = forall a. Text -> IO (Either Text a) -> IO (Either Text a)
try_e Text
"load_next_history" forall a b. (a -> b) -> a -> b
$ do
    -- This won't work if I loaded something off-head.  In that case, I need
    -- the checkpoint I started from so I can start from there instead of HEAD.
    [Commit]
commits <- [Char] -> IO [Commit]
Git.read_log_head [Char]
repo
    case forall {a}. Eq a => a -> [a] -> Maybe a
find_before Commit
commit [Commit]
commits of
        Maybe Commit
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a. Maybe a
Nothing
        Just Commit
child -> [Char]
-> State
-> Commit
-> Commit
-> IO (Either Text (Maybe LoadHistory))
load_history [Char]
repo State
state Commit
commit Commit
child
    where
    find_before :: a -> [a] -> Maybe a
find_before a
val (a
x1:a
x2:[a]
xs)
        | a
val forall a. Eq a => a -> a -> Bool
== a
x2 = forall a. a -> Maybe a
Just a
x1
        | Bool
otherwise = a -> [a] -> Maybe a
find_before a
val (a
x2forall a. a -> [a] -> [a]
:[a]
xs)
    find_before a
_ [a]
_ = forall a. Maybe a
Nothing

-- | Load a history, either in the past or the future.
--
-- Multiple futures:
-- I get the future by tracing from HEAD.  Then if you undo and redo, that
-- branch will be orphaned, and the next gc will probably delete it.  But if
-- you save there, the tag will probably keep it alive.  Then the next
-- history commit will set the HEAD to this branch, and the old HEAD will only
-- be preserved if it had a ref.
load_history :: Git.Repo -> Ui.State -> Commit -> Commit
    -> IO (Either Text (Maybe LoadHistory))
load_history :: [Char]
-> State
-> Commit
-> Commit
-> IO (Either Text (Maybe LoadHistory))
load_history [Char]
repo State
state Commit
from_commit Commit
to_commit = do
    [Text]
names <- [Char] -> IO [Text]
parse_names forall b c a. (b -> c) -> (a -> b) -> a -> c
. CommitData -> [Char]
Git.commit_text
        forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Char] -> Commit -> IO CommitData
Git.read_commit [Char]
repo Commit
to_commit
    Either Text (State, UiDamage)
result <- [Char]
-> Commit
-> Maybe Commit
-> State
-> IO (Either Text (State, UiDamage))
load_from [Char]
repo Commit
from_commit (forall a. a -> Maybe a
Just Commit
to_commit) State
state
    case Either Text (State, UiDamage)
result of
        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 Text
err
        Right (State
new_state, UiDamage
damage) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
            State -> Commit -> UiDamage -> [Text] -> LoadHistory
LoadHistory State
new_state Commit
to_commit UiDamage
damage [Text]
names

load_from :: Git.Repo -> Commit -> Maybe Commit -> Ui.State
    -> IO (Either Text (Ui.State, Update.UiDamage))
load_from :: [Char]
-> Commit
-> Maybe Commit
-> State
-> IO (Either Text (State, UiDamage))
load_from [Char]
repo Commit
commit_from Maybe Commit
maybe_commit_to State
state = do
    Commit
commit_to <- [Char] -> Maybe Commit -> IO Commit
default_head [Char]
repo Maybe Commit
maybe_commit_to
    [Modification]
mods <- [Char] -> Commit -> Commit -> IO [Modification]
Git.diff_commits [Char]
repo Commit
commit_from Commit
commit_to
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ State -> [Modification] -> Either Text (State, UiDamage)
undump_diff State
state [Modification]
mods

default_head :: Git.Repo -> Maybe Commit -> IO Commit
default_head :: [Char] -> Maybe Commit -> IO Commit
default_head [Char]
_ (Just Commit
commit) = forall (m :: * -> *) a. Monad m => a -> m a
return Commit
commit
default_head [Char]
repo Maybe Commit
Nothing =
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. [Char] -> IO a
Git.throw forall a b. (a -> b) -> a -> b
$ [Char]
"repo with no HEAD commit: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show [Char]
repo)
        forall (m :: * -> *) a. Monad m => a -> m a
return forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Char] -> IO (Maybe Commit)
Git.read_head_commit [Char]
repo

-- | Each commit saves the name of the command, so when you load it, it still
-- has the proper name.
--
-- TODO save and parse in a more robust way
parse_names :: String -> IO [Text]
parse_names :: [Char] -> IO [Text]
parse_names [Char]
text = case [Char] -> [[Char]]
lines [Char]
text of
    [[Char]
_, [Char]
names] -> forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Text
txt forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Read a => [Char] -> IO a
readIO [Char]
names
    [[Char]]
_ -> forall a. Stack => Text -> a
errorStack forall a b. (a -> b) -> a -> b
$ Text
"can't parse description: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt [Char]
text

unparse_names :: String -> [Text] -> String
unparse_names :: [Char] -> [Text] -> [Char]
unparse_names [Char]
msg [Text]
names = [Char]
msg forall a. [a] -> [a] -> [a]
++ [Char]
"\n" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show [Text]
names forall a. [a] -> [a] -> [a]
++ [Char]
"\n"

-- * views

save_views :: Git.Repo -> Map ViewId Block.View -> IO ()
save_views :: [Char] -> Map ViewId View -> IO ()
save_views [Char]
repo =
    forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Serialize a => Magic a -> [Char] -> a -> IO Bool
Serialize.serialize Magic (Map ViewId View)
Cmd.Serialize.views_magic ([Char]
repo [Char] -> ShowS
</> [Char]
"views")

load_views :: Git.Repo -> IO (Either Text (Map ViewId Block.View))
load_views :: [Char] -> IO (Either Text (Map ViewId View))
load_views [Char]
repo =
    forall a.
Serialize a =>
Magic a -> [Char] -> IO (Either UnserializeError a)
Serialize.unserialize Magic (Map ViewId View)
Cmd.Serialize.views_magic ([Char]
repo [Char] -> ShowS
</> [Char]
"views") forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left (Serialize.IOError IOError
exc) | IOError -> Bool
IO.Error.isDoesNotExistError IOError
exc ->
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a. Monoid a => a
mempty
        Left UnserializeError
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. Pretty a => a -> Text
pretty UnserializeError
err)
        Right Map ViewId View
views -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right Map ViewId View
views

-- * dump / undump

dump :: Ui.State -> [(FilePath, ByteString)]
dump :: State -> [([Char], ByteString)]
dump (Ui.State Map ViewId View
_views Map BlockId Block
blocks Map TrackId Track
tracks Map RulerId Ruler
rulers Config
config) =
    forall id a.
(Ident id, Serialize a) =>
Map id a -> [([Char], ByteString)]
dump_map Map BlockId Block
blocks forall a. [a] -> [a] -> [a]
++ forall id a.
(Ident id, Serialize a) =>
Map id a -> [([Char], ByteString)]
dump_map Map TrackId Track
tracks forall a. [a] -> [a] -> [a]
++ forall id a.
(Ident id, Serialize a) =>
Map id a -> [([Char], ByteString)]
dump_map Map RulerId Ruler
rulers
    forall a. [a] -> [a] -> [a]
++ [([Char]
"config", forall a. Serialize a => a -> ByteString
Serialize.encode Config
config)]

dump_map :: (Ident id, Serialize.Serialize a) =>
    Map id a -> [(FilePath, ByteString)]
dump_map :: forall id a.
(Ident id, Serialize a) =>
Map id a -> [([Char], ByteString)]
dump_map Map id a
m = do
    (id
ident, a
val) <- forall k a. Map k a -> [(k, a)]
Map.toAscList Map id a
m
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall id. Ident id => id -> [Char]
id_to_path id
ident, forall a. Serialize a => a -> ByteString
Serialize.encode a
val)

-- | This will tend to create redundant files, e.g. a block will be written
-- twice if two updates occur on it.  But 'Git.modify_dir' will filter out the
-- extras.
dump_diff :: Bool -> Ui.State -> [Update.UiUpdate]
    -> ([Text], [Git.Modification])
    -- ^ warnings for updates to values that no longer exist
dump_diff :: Bool -> State -> [UiUpdate] -> ([Text], [Modification])
dump_diff Bool
track_dir State
state =
    -- I use Left "" as a nop, so filter those out.
    forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
Text.null)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [Either a b] -> ([a], [b])
Either.partitionEithers forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall {t}. Pretty t => Update t State -> Either Text Modification
mk
    where
    mk :: Update t State -> Either Text Modification
mk (Update.View {}) = forall a b. a -> Either a b
Left Text
""
    mk u :: Update t State
u@(Update.Block BlockId
block_id Block t
_)
        | Just Block
block <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup BlockId
block_id (State -> Map BlockId Block
Ui.state_blocks State
state) =
            forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ [Char] -> ByteString -> Modification
Git.Add (forall id. Ident id => id -> [Char]
id_to_path BlockId
block_id) (forall a. Serialize a => a -> ByteString
Serialize.encode Block
block)
        | Bool
otherwise = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"block_id: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Update t State
u
    mk u :: Update t State
u@(Update.Track TrackId
track_id Track
update)
        | Just Track
track <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TrackId
track_id (State -> Map TrackId Track
Ui.state_tracks State
state) =
            case Track
update of
                Update.TrackEvents ScoreTime
start ScoreTime
end | Bool
track_dir ->
                    forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ State -> TrackId -> ScoreTime -> ScoreTime -> Modification
dump_events State
state TrackId
track_id ScoreTime
start ScoreTime
end
                Track
_ -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$
                    [Char] -> ByteString -> Modification
Git.Add (forall id. Ident id => id -> [Char]
id_to_path TrackId
track_id) (forall a. Serialize a => a -> ByteString
Serialize.encode Track
track)
        | Bool
otherwise = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"track_id: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Update t State
u
    mk (Update.Ruler RulerId
ruler_id)
        | Just Ruler
ruler <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup RulerId
ruler_id (State -> Map RulerId Ruler
Ui.state_rulers State
state) =
            forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ [Char] -> ByteString -> Modification
Git.Add (forall id. Ident id => id -> [Char]
id_to_path RulerId
ruler_id) (forall a. Serialize a => a -> ByteString
Serialize.encode Ruler
ruler)
        | Bool
otherwise = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"ruler_id: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty RulerId
ruler_id
    mk (Update.State State
update) = case State
update of
        Update.Config Config
config ->
            forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ [Char] -> ByteString -> Modification
Git.Add [Char]
"config" (forall a. Serialize a => a -> ByteString
Serialize.encode Config
config)
        Update.CreateBlock BlockId
block_id Block
block ->
            forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ [Char] -> ByteString -> Modification
Git.Add (forall id. Ident id => id -> [Char]
id_to_path BlockId
block_id) (forall a. Serialize a => a -> ByteString
Serialize.encode Block
block)
        Update.DestroyBlock BlockId
block_id ->
            forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ [Char] -> Modification
Git.Remove (forall id. Ident id => id -> [Char]
id_to_path BlockId
block_id)
        Update.CreateTrack TrackId
track_id Track
track ->
            forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ [Char] -> ByteString -> Modification
Git.Add (forall id. Ident id => id -> [Char]
id_to_path TrackId
track_id) (forall a. Serialize a => a -> ByteString
Serialize.encode Track
track)
        Update.DestroyTrack TrackId
track_id ->
            forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ [Char] -> Modification
Git.Remove (forall id. Ident id => id -> [Char]
id_to_path TrackId
track_id)
        Update.CreateRuler RulerId
ruler_id Ruler
ruler ->
            forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ [Char] -> ByteString -> Modification
Git.Add (forall id. Ident id => id -> [Char]
id_to_path RulerId
ruler_id) (forall a. Serialize a => a -> ByteString
Serialize.encode Ruler
ruler)
        Update.DestroyRuler RulerId
ruler_id ->
            forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ [Char] -> Modification
Git.Remove (forall id. Ident id => id -> [Char]
id_to_path RulerId
ruler_id)

undump :: Git.Dir -> Either Text Ui.State
undump :: Dir -> Either Text State
undump Dir
dir = do
    Map BlockId Block
blocks <- forall a id.
(Serialize a, Ord id) =>
(Id -> id) -> Dir -> Either Text (Map id a)
undump_map Id -> BlockId
Id.BlockId forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Char] -> Either Text Dir
get_dir [Char]
"blocks"
    Map TrackId Track
tracks <- forall a id.
(Serialize a, Ord id) =>
(Id -> id) -> Dir -> Either Text (Map id a)
undump_map Id -> TrackId
Id.TrackId forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Char] -> Either Text Dir
get_dir [Char]
"tracks"
    Map RulerId Ruler
rulers <- forall a id.
(Serialize a, Ord id) =>
(Id -> id) -> Dir -> Either Text (Map id a)
undump_map Id -> RulerId
Id.RulerId forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Char] -> Either Text Dir
get_dir [Char]
"rulers"
    Config
config <- forall a. Serialize a => Text -> ByteString -> Either Text a
decode Text
"config" forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Char] -> Either Text ByteString
get_file [Char]
"config"
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Map ViewId View
-> Map BlockId Block
-> Map TrackId Track
-> Map RulerId Ruler
-> Config
-> State
Ui.State forall a. Monoid a => a
mempty Map BlockId Block
blocks Map TrackId Track
tracks Map RulerId Ruler
rulers Config
config
    where
    get_dir :: [Char] -> Either Text Dir
get_dir [Char]
name = case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup [Char]
name Dir
dir of
        Maybe File
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall k a. Map k a
Map.empty
        Just (Git.File ByteString
_) -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"expected dir but got file: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt [Char]
name
        Just (Git.Dir Dir
dir) -> forall (m :: * -> *) a. Monad m => a -> m a
return Dir
dir
    get_file :: [Char] -> Either Text ByteString
get_file [Char]
name = case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup [Char]
name Dir
dir of
        Maybe File
Nothing -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"file not found: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt [Char]
name
        Just (Git.Dir Dir
_) -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"expected file but got dir: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt [Char]
name
        Just (Git.File ByteString
bytes) -> forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
bytes

undump_map :: (Serialize.Serialize a, Ord id) =>
    (Id.Id -> id) -> Map Git.FileName Git.File -> Either Text (Map id a)
undump_map :: forall a id.
(Serialize a, Ord id) =>
(Id -> id) -> Dir -> Either Text (Map id a)
undump_map Id -> id
mkid Dir
dir =
    forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {a}. Serialize a => ([Char], File) -> Either Text [(id, a)]
dir_subs (forall k a. Map k a -> [(k, a)]
Map.toAscList Dir
dir)
    where
    dir_subs :: ([Char], File) -> Either Text [(id, a)]
dir_subs ([Char]
name, Git.File ByteString
_) =
        forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"expected dir but got file: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt [Char]
name
    dir_subs ([Char]
name, Git.Dir Dir
subs) = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall {a}.
Serialize a =>
[Char] -> ([Char], File) -> Either Text (id, a)
undump_file [Char]
name) (forall k a. Map k a -> [(k, a)]
Map.toList Dir
subs)
    undump_file :: [Char] -> ([Char], File) -> Either Text (id, a)
undump_file [Char]
_ ([Char]
name, Git.Dir Dir
_) =
        forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"expected file but got dir: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt [Char]
name
    undump_file [Char]
ns ([Char]
name, Git.File ByteString
bytes) =
        (,) (forall id. (Id -> id) -> [Char] -> [Char] -> id
path_to_id Id -> id
mkid [Char]
ns [Char]
name) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Serialize a => Text -> ByteString -> Either Text a
decode ([Char] -> Text
txt [Char]
name) ByteString
bytes

undump_diff :: Ui.State -> [Git.Modification]
    -> Either Text (Ui.State, Update.UiDamage)
undump_diff :: State -> [Modification] -> Either Text (State, UiDamage)
undump_diff State
state = forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (State, UiDamage) -> Modification -> Either Text (State, UiDamage)
apply (State
state, forall a. Monoid a => a
mempty)
    where
    apply :: (State, UiDamage) -> Modification -> Either Text (State, UiDamage)
apply (State
state, UiDamage
update) (Git.Remove [Char]
path) = case [Char] -> [[Char]]
split [Char]
path of
        [[Char]
"blocks", [Char]
ns, [Char]
name] -> forall {k} {a}.
(Show k, Ord k) =>
[Char]
-> [Char]
-> (Id -> k)
-> Lens State (Map k a)
-> Either Text (State, UiDamage)
delete [Char]
ns [Char]
name Id -> BlockId
Id.BlockId Lens State (Map BlockId Block)
Ui.blocks
        [[Char]
"tracks", [Char]
ns, [Char]
name] -> forall {k} {a}.
(Show k, Ord k) =>
[Char]
-> [Char]
-> (Id -> k)
-> Lens State (Map k a)
-> Either Text (State, UiDamage)
delete [Char]
ns [Char]
name Id -> TrackId
Id.TrackId Lens State (Map TrackId Track)
Ui.tracks
        [[Char]
"rulers", [Char]
ns, [Char]
name] -> forall {k} {a}.
(Show k, Ord k) =>
[Char]
-> [Char]
-> (Id -> k)
-> Lens State (Map k a)
-> Either Text (State, UiDamage)
delete [Char]
ns [Char]
name Id -> RulerId
Id.RulerId Lens State (Map RulerId Ruler)
Ui.rulers
        [[Char]]
_ -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"unknown file deleted: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt [Char]
path
        where
        delete :: [Char]
-> [Char]
-> (Id -> k)
-> Lens State (Map k a)
-> Either Text (State, UiDamage)
delete [Char]
ns [Char]
name Id -> k
mkid Lens State (Map k a)
lens = do
            let ident :: k
ident = forall id. (Id -> id) -> [Char] -> [Char] -> id
path_to_id Id -> k
mkid [Char]
ns [Char]
name
            Map k a
vals <- forall k a.
(Show k, Ord k) =>
k -> Map k a -> Either Text (Map k a)
delete_key k
ident (Lens State (Map k a)
lens forall f a. Lens f a -> f -> a
#$ State
state)
            forall (m :: * -> *) a. Monad m => a -> m a
return ((Lens State (Map k a)
lens forall f a. Lens f a -> a -> f -> f
#= Map k a
vals) State
state, UiDamage
update)
    apply (State
state, UiDamage
update) (Git.Add [Char]
path ByteString
bytes) = case [Char] -> [[Char]]
split [Char]
path of
        [[Char]
"blocks", [Char]
ns, [Char]
name] -> (, UiDamage
update) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {a} {k}.
(Serialize a, Ord k) =>
[Char]
-> [Char] -> (Id -> k) -> Lens State (Map k a) -> Either Text State
add [Char]
ns [Char]
name Id -> BlockId
Id.BlockId Lens State (Map BlockId Block)
Ui.blocks
        [[Char]
"tracks", [Char]
ns, [Char]
name] -> do
            State
state_to <- forall {a} {k}.
(Serialize a, Ord k) =>
[Char]
-> [Char] -> (Id -> k) -> Lens State (Map k a) -> Either Text State
add [Char]
ns [Char]
name Id -> TrackId
Id.TrackId Lens State (Map TrackId Track)
Ui.tracks
            let tid :: TrackId
tid = forall id. (Id -> id) -> [Char] -> [Char] -> id
path_to_id Id -> TrackId
Id.TrackId [Char]
ns [Char]
name
            -- I don't save the UiDamage with the checkpoint, so to avoid
            -- having to rederive the entire track I do a little mini-diff
            -- just on the track.  It shouldn't be too expensive because it's
            -- only on one track at a time.
            let event_updates :: UiDamage
event_updates = State -> State -> TrackId -> UiDamage
Diff.track_diff State
state State
state_to TrackId
tid
            forall (m :: * -> *) a. Monad m => a -> m a
return (State
state_to, UiDamage
event_updates forall a. Semigroup a => a -> a -> a
<> UiDamage
update)
        [[Char]
"rulers", [Char]
ns, [Char]
name] -> do
            State
state_to <- forall {a} {k}.
(Serialize a, Ord k) =>
[Char]
-> [Char] -> (Id -> k) -> Lens State (Map k a) -> Either Text State
add [Char]
ns [Char]
name Id -> RulerId
Id.RulerId Lens State (Map RulerId Ruler)
Ui.rulers
            let rid :: Set RulerId
rid = forall a. a -> Set a
Set.singleton forall a b. (a -> b) -> a -> b
$ forall id. (Id -> id) -> [Char] -> [Char] -> id
path_to_id Id -> RulerId
Id.RulerId [Char]
ns [Char]
name
            forall (m :: * -> *) a. Monad m => a -> m a
return (State
state_to, forall a. Monoid a => a
mempty { _rulers :: Set RulerId
Update._rulers = Set RulerId
rid } forall a. Semigroup a => a -> a -> a
<> UiDamage
update)
        [[Char]
"config"] -> do
            Config
val <- forall a. Serialize a => Text -> ByteString -> Either Text a
decode ([Char] -> Text
txt [Char]
path) ByteString
bytes
            forall (m :: * -> *) a. Monad m => a -> m a
return ((Lens State Config
Ui.config forall f a. Lens f a -> a -> f -> f
#= Config
val) State
state, UiDamage
update)
        [[Char]]
_ -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"unknown file modified: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt [Char]
path
        where
        add :: [Char]
-> [Char] -> (Id -> k) -> Lens State (Map k a) -> Either Text State
add [Char]
ns [Char]
name Id -> k
mkid Lens State (Map k a)
lens = do
            let ident :: k
ident = forall id. (Id -> id) -> [Char] -> [Char] -> id
path_to_id Id -> k
mkid [Char]
ns [Char]
name
            a
val <- forall a. Serialize a => Text -> ByteString -> Either Text a
decode ([Char] -> Text
txt [Char]
path) ByteString
bytes
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (Lens State (Map k a)
lens forall f a. Lens f a -> (a -> a) -> f -> f
%= forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert k
ident a
val) State
state
    split :: [Char] -> [[Char]]
split = [Char] -> [[Char]]
FilePath.splitDirectories

class Ident id where id_to_path :: id -> FilePath
instance Ident BlockId where id_to_path :: BlockId -> [Char]
id_to_path = forall a. Ident a => [Char] -> a -> [Char]
make_id_path [Char]
"blocks"
instance Ident TrackId where id_to_path :: TrackId -> [Char]
id_to_path = forall a. Ident a => [Char] -> a -> [Char]
make_id_path [Char]
"tracks"
instance Ident RulerId where id_to_path :: RulerId -> [Char]
id_to_path = forall a. Ident a => [Char] -> a -> [Char]
make_id_path [Char]
"rulers"

make_id_path :: (Id.Ident a) => FilePath -> a -> FilePath
make_id_path :: forall a. Ident a => [Char] -> a -> [Char]
make_id_path [Char]
dir a
id = [Char]
dir [Char] -> ShowS
</> Text -> [Char]
untxt Text
nsdir [Char] -> ShowS
</> Text -> [Char]
untxt Text
name
    where
    (Namespace
ns, Text
name) = Id -> (Namespace, Text)
Id.un_id (forall a. Ident a => a -> Id
Id.unpack_id a
id)
    nsdir :: Text
nsdir
        | Namespace
ns forall a. Eq a => a -> a -> Bool
== Namespace
Id.global_namespace = Text
"*GLOBAL*"
        | Bool
otherwise = Namespace -> Text
Id.un_namespace Namespace
ns

path_to_id :: (Id.Id -> id) -> FilePath -> FilePath -> id
path_to_id :: forall id. (Id -> id) -> [Char] -> [Char] -> id
path_to_id Id -> id
mkid [Char]
ns [Char]
name = Id -> id
mkid (Namespace -> Text -> Id
Id.id Namespace
save_ns ([Char] -> Text
txt [Char]
name))
    where
    save_ns :: Namespace
save_ns
        | [Char]
ns forall a. Eq a => a -> a -> Bool
== [Char]
"*GLOBAL*" = Namespace
Id.global_namespace
        | Bool
otherwise = Text -> Namespace
Id.namespace ([Char] -> Text
txt [Char]
ns)

-- * util

-- | If a string looks like a commit hash, return the commit, otherwise look
-- for a ref in tags\/.
infer_commit :: Git.Repo -> String -> IO (Maybe Commit)
infer_commit :: [Char] -> [Char] -> IO (Maybe Commit)
infer_commit [Char]
repo [Char]
ref_or_commit = case [Char] -> Maybe Commit
Git.parse_commit [Char]
ref_or_commit of
    Just Commit
commit -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Commit
commit
    Maybe Commit
Nothing -> [Char] -> [Char] -> IO (Maybe Commit)
Git.read_ref [Char]
repo ([Char]
"tags" [Char] -> ShowS
</> [Char]
ref_or_commit)

catch :: IO a -> IO (Maybe a)
catch :: forall a. IO a -> IO (Maybe a)
catch IO a
io = do
    Either GitException a
result <- forall e a. Exception e => IO a -> IO (Either e a)
Exception.try IO a
io
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Either GitException a
result of
        Left (Git.GitException [Char]
_) -> forall a. Maybe a
Nothing
        Right a
val -> forall a. a -> Maybe a
Just a
val

try :: Text -> IO a -> IO (Either Text a)
try :: forall a. Text -> IO a -> IO (Either Text a)
try Text
caller IO a
io = do
    Either GitException a
result <- forall e a. Exception e => IO a -> IO (Either e a)
Exception.try IO a
io
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Either GitException a
result of
        Left (Git.GitException [Char]
err) -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
caller forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
txt [Char]
err
        Right a
val -> forall a b. b -> Either a b
Right a
val

try_e :: Text -> IO (Either Text a) -> IO (Either Text a)
try_e :: forall a. Text -> IO (Either Text a) -> IO (Either Text a)
try_e Text
caller IO (Either Text a)
io = do
    Either GitException (Either Text a)
result <- forall e a. Exception e => IO a -> IO (Either e a)
Exception.try IO (Either Text a)
io
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Either GitException (Either Text a)
result of
        Left (Git.GitException [Char]
err) -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
caller forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
txt [Char]
err
        Right (Left Text
err) -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
caller forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> Text
err
        Right (Right a
val) -> forall a b. b -> Either a b
Right a
val

delete_key :: (Show k, Ord k) => k -> Map k a -> Either Text (Map k a)
delete_key :: forall k a.
(Show k, Ord k) =>
k -> Map k a -> Either Text (Map k a)
delete_key k
k Map k a
m
    | forall k a. Ord k => k -> Map k a -> Bool
Map.member k
k Map k a
m = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Map k a
Map.delete k
k Map k a
m
    | Bool
otherwise = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"deleted key " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt k
k forall a. Semigroup a => a -> a -> a
<> Text
" not present: "
        forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt (forall k a. Map k a -> [k]
Map.keys Map k a
m)

decode :: Serialize.Serialize a => Text -> ByteString -> Either Text a
decode :: forall a. Serialize a => Text -> ByteString -> Either Text a
decode Text
msg = forall a. Text -> Either Text a -> Either Text a
with_msg Text
msg forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first [Char] -> Text
txt forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Serialize a => ByteString -> Either [Char] a
Serialize.decode

-- | Annotate a failable computation.
with_msg :: Text -> Either Text a -> Either Text a
with_msg :: forall a. Text -> Either Text a -> Either Text a
with_msg Text
msg (Left Text
err) = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
msg forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> Text
err
with_msg Text
_ (Right a
val) = forall a b. b -> Either a b
Right a
val

-- * config

get_user :: IO (Either Text SaveGitT.User)
get_user :: IO (Either Text User)
get_user = forall e a. Exception e => (e -> IO a) -> IO a -> IO a
Exception.handle forall {m :: * -> *} {b}. Monad m => IOError -> m (Either Text b)
handle forall a b. (a -> b) -> a -> b
$ do
    [Text]
lines <- Text -> [Text]
Text.lines forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
txt forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> [[Char]] -> [Char] -> IO [Char]
Process.readProcess [Char]
"git"
        [[Char]
"config", [Char]
"--get-regexp", [Char]
"user.(name|email)"] [Char]
""
    let m :: Map Text Text
m = Text -> Text
Text.strip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (forall a b. (a -> b) -> [a] -> [b]
map ((Char -> Bool) -> Text -> (Text, Text)
Text.break (forall a. Eq a => a -> a -> Bool
==Char
' ')) [Text]
lines)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
"user.name" Map Text Text
m, forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
"user.email" Map Text Text
m) of
        (Just Text
name, Just Text
email)
            | Bool -> Bool
not (Text -> Bool
Text.null Text
name) Bool -> Bool -> Bool
&& Bool -> Bool
not (Text -> Bool
Text.null Text
email) ->
                forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Text -> Text -> User
SaveGitT.User Text
name Text
email
        (Maybe Text, Maybe Text)
_ -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"user.name and user.email not set in git config output: "
            forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt [Text]
lines
    where
    handle :: IOError -> m (Either Text b)
handle IOError
exc = 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
"error getting git config: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt (IOError
exc :: IO.Error.IOError)