-- 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.File as File
import qualified Util.Git as Git
import           Util.GitT (Commit, Repo)
import qualified Util.Log as Log
import qualified Util.Seq as Seq
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]
(Int -> LoadHistory -> ShowS)
-> (LoadHistory -> [Char])
-> ([LoadHistory] -> ShowS)
-> Show LoadHistory
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 = Text -> IO SavePoint -> IO (Either Text SavePoint)
forall a. Text -> IO a -> IO (Either Text a)
try Text
"set_save_tag" (IO SavePoint -> IO (Either Text SavePoint))
-> IO SavePoint -> IO (Either Text SavePoint)
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 (Commit -> Maybe Commit
forall a. a -> Maybe a
Just Commit
commit) IO (Maybe (SavePoint, Commit))
-> (Maybe (SavePoint, Commit) -> IO SavePoint) -> IO SavePoint
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
            SavePoint -> IO SavePoint
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 Commit -> Commit -> Bool
forall a. Eq a => a -> a -> Bool
== Commit
save_commit then SavePoint -> IO SavePoint
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 IO () -> IO SavePoint -> IO SavePoint
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> SavePoint -> IO SavePoint
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
(SavePoint -> SavePoint -> Bool)
-> (SavePoint -> SavePoint -> Bool) -> Eq SavePoint
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]
(Int -> SavePoint -> ShowS)
-> (SavePoint -> [Char])
-> ([SavePoint] -> ShowS)
-> Show SavePoint
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
(SavePoint -> Text)
-> (SavePoint -> Doc) -> ([SavePoint] -> Doc) -> Pretty SavePoint
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 <- IO [Commit] -> IO (Maybe [Commit])
forall a. IO a -> IO (Maybe a)
catch (IO [Commit] -> IO (Maybe [Commit]))
-> IO [Commit] -> IO (Maybe [Commit])
forall a b. (a -> b) -> a -> b
$
        IO [Commit]
-> (Commit -> IO [Commit]) -> Maybe Commit -> IO [Commit]
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 = [Commit] -> Maybe [Commit] -> [Commit]
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 = [(Commit, SavePoint)] -> Map Commit SavePoint
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Commit, SavePoint)] -> Map Commit SavePoint)
-> [(Commit, SavePoint)] -> Map Commit SavePoint
forall a b. (a -> b) -> a -> b
$ do
            ([Char]
ref, Commit
commit) <- Map [Char] Commit -> [([Char], Commit)]
forall k a. Map k a -> [(k, a)]
Map.toList Map [Char] Commit
refs
            Just SavePoint
save <- Maybe SavePoint -> [Maybe SavePoint]
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe SavePoint -> [Maybe SavePoint])
-> Maybe SavePoint -> [Maybe SavePoint]
forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe SavePoint
ref_to_save [Char]
ref
            (Commit, SavePoint) -> [(Commit, SavePoint)]
forall (m :: * -> *) a. Monad m => a -> m a
return (Commit
commit, SavePoint
save)
    Maybe (SavePoint, Commit) -> IO (Maybe (SavePoint, Commit))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (SavePoint, Commit) -> IO (Maybe (SavePoint, Commit)))
-> Maybe (SavePoint, Commit) -> IO (Maybe (SavePoint, Commit))
forall a b. (a -> b) -> a -> b
$ [(SavePoint, Commit)] -> Maybe (SavePoint, Commit)
forall a. [a] -> Maybe a
Seq.head [(SavePoint
save, Commit
commit) | (Just SavePoint
save, Commit
commit)
        <- [Maybe SavePoint] -> [Commit] -> [(Maybe SavePoint, Commit)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((Commit -> Maybe SavePoint) -> [Commit] -> [Maybe SavePoint]
forall a b. (a -> b) -> [a] -> [b]
map (Commit -> Map Commit SavePoint -> Maybe SavePoint
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 =
    Maybe SavePoint -> IO SavePoint
forall {a}. Maybe a -> IO a
from_just (Maybe SavePoint -> IO SavePoint)
-> IO (Maybe SavePoint) -> IO SavePoint
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (SavePoint -> IO Bool) -> [SavePoint] -> IO (Maybe SavePoint)
forall (m :: * -> *) a.
Monad m =>
(a -> m Bool) -> [a] -> m (Maybe a)
findM SavePoint -> IO Bool
save_free ((SavePoint -> SavePoint) -> SavePoint -> [SavePoint]
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 = Maybe Commit -> Bool
forall a. Maybe a -> Bool
Maybe.isNothing (Maybe Commit -> Bool) -> IO (Maybe Commit) -> IO Bool
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 = IO a -> (a -> IO a) -> Maybe a -> IO a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe -- This should never happen since iterate tries forever.
        ([Char] -> IO a
forall a. [Char] -> IO a
Git.throw ([Char] -> IO a) -> [Char] -> IO a
forall a b. (a -> b) -> a -> b
$ [Char]
"couldn't find a free save name after " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ SavePoint -> [Char]
forall a. Show a => a -> [Char]
show SavePoint
save)
        a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
    split :: SavePoint -> SavePoint
split (SavePoint [Int]
xs) = [Int] -> SavePoint
SavePoint (Int
0 Int -> [Int] -> [Int]
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> [Int] -> [Int]
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 (([Char] -> Bool) -> [[Char]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((Char -> Bool) -> [Char] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
Char.isDigit) [[Char]]
versions) = Maybe SavePoint
forall a. Maybe a
Nothing
    | Bool
otherwise = SavePoint -> Maybe SavePoint
forall a. a -> Maybe a
Just (SavePoint -> Maybe SavePoint) -> SavePoint -> Maybe SavePoint
forall a b. (a -> b) -> a -> b
$ [Int] -> SavePoint
SavePoint ([Int] -> [Int]
forall a. [a] -> [a]
reverse (([Char] -> Int) -> [[Char]] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Int
forall a. Read a => [Char] -> a
read [[Char]]
versions))
    where
    ([Char]
save, Bool
_) = [Char] -> [Char] -> ([Char], Bool)
forall a. Eq a => [a] -> [a] -> ([a], Bool)
Seq.drop_prefix [Char]
"tags/" [Char]
ref
    versions :: [[Char]]
versions = [Char] -> [Char] -> [[Char]]
forall a. Eq a => NonNull a -> NonNull a -> NonNull (NonNull a)
Seq.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
</> [Char] -> [[Char]] -> [Char]
forall a. Monoid a => a -> [a] -> a
Seq.join [Char]
"." ((Int -> [Char]) -> [Int] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Int -> [Char]
forall a. Show a => a -> [Char]
show ([Int] -> [Int]
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) =
    Text -> IO Commit -> IO (Either Text Commit)
forall a. Text -> IO a -> IO (Either Text a)
try Text
"save" (IO Commit -> IO (Either Text Commit))
-> IO Commit -> IO (Either Text Commit)
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) =
        Text -> IO Commit -> IO (Either Text Commit)
forall a. Text -> IO a -> IO (Either Text a)
try Text
"checkpoint" (IO Commit -> IO (Either Text Commit))
-> IO Commit -> IO (Either Text Commit)
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 ((UiUpdate -> Bool) -> [UiUpdate] -> [UiUpdate]
forall a. (a -> Bool) -> [a] -> [a]
filter UiUpdate -> Bool
should_record [UiUpdate]
updates)
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Text] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
not_found) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        Text -> IO ()
forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.warn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"ignored updates for nonexistent "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
", " [Text]
not_found
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"; this probably means 'Ui.Diff.cancel_updates didn't do its job"
    if [Modification] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Modification]
mods then Commit -> IO Commit
forall (m :: * -> *) a. Monad m => a -> m a
return Commit
commit else do
        IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM ([Char] -> IO Bool
File.writable [Char]
repo) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            [Char] -> IO ()
forall a. [Char] -> IO a
Git.throw ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"git repo is not writable: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> ShowS
forall a. Show a => a -> [Char]
show [Char]
repo
        Tree
last_tree <- CommitData -> Tree
Git.commit_tree (CommitData -> Tree) -> IO CommitData -> IO 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 (Commit -> Maybe Commit
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
    IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM ([Char] -> IO Bool
Git.init [Char]
repo) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        [Char] -> IO ()
forall a. [Char] -> IO a
Git.throw [Char]
"refusing to overwrite a repo that already exists"
    Dir
dir <- ([Char] -> IO Dir)
-> (Dir -> IO Dir) -> Either [Char] Dir -> IO Dir
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ([Char] -> IO Dir
forall a. [Char] -> IO a
Git.throw ([Char] -> IO Dir) -> ShowS -> [Char] -> IO Dir
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
"make_dir: "<>)) Dir -> IO Dir
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [Char] Dir -> IO Dir) -> Either [Char] Dir -> IO Dir
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 Maybe Commit
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 (Bool -> Bool) -> Bool -> Bool
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)
        ([Commit] -> (Commit -> [Commit]) -> Maybe Commit -> [Commit]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (Commit -> [Commit] -> [Commit]
forall a. a -> [a] -> [a]
:[]) Maybe Commit
maybe_parent) Tree
tree [Char]
desc
    [Char] -> Commit -> IO ()
Git.update_head [Char]
repo Commit
commit
    Commit -> IO 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) (ByteString -> Modification) -> ByteString -> Modification
forall a b. (a -> b) -> a -> b
$
        EventsUpdate -> ByteString
forall a. Serialize a => a -> ByteString
Serialize.encode (EventsUpdate -> ByteString) -> EventsUpdate -> ByteString
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 = Events -> (Track -> Events) -> Maybe Track -> 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) (Events -> Events) -> (Track -> Events) -> Track -> Events
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Track -> Events
Track.track_events)
        (TrackId -> Map TrackId Track -> Maybe 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))

-- | 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 = TrackId -> [Char]
forall id. Ident id => id -> [Char]
id_to_path TrackId
track_id [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"_"
    [Char] -> ShowS
</> ScoreTime -> [Char]
score_to_hex ScoreTime
start [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"-" [Char] -> ShowS
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]
(Int -> EventsUpdate -> ShowS)
-> (EventsUpdate -> [Char])
-> ([EventsUpdate] -> ShowS)
-> Show EventsUpdate
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) = Putter TrackId
forall a. Serialize a => Putter a
Serialize.put TrackId
a PutM () -> PutM () -> PutM ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Putter ScoreTime
forall a. Serialize a => Putter a
Serialize.put ScoreTime
b
        PutM () -> PutM () -> PutM ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Putter ScoreTime
forall a. Serialize a => Putter a
Serialize.put ScoreTime
c PutM () -> PutM () -> PutM ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Putter Events
forall a. Serialize a => Putter a
Serialize.put Events
d
    get :: Get EventsUpdate
get = TrackId -> ScoreTime -> ScoreTime -> Events -> EventsUpdate
EventsUpdate (TrackId -> ScoreTime -> ScoreTime -> Events -> EventsUpdate)
-> Get TrackId
-> Get (ScoreTime -> ScoreTime -> Events -> EventsUpdate)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get TrackId
forall a. Serialize a => Get a
Serialize.get Get (ScoreTime -> ScoreTime -> Events -> EventsUpdate)
-> Get ScoreTime -> Get (ScoreTime -> Events -> EventsUpdate)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get ScoreTime
forall a. Serialize a => Get a
Serialize.get Get (ScoreTime -> Events -> EventsUpdate)
-> Get ScoreTime -> Get (Events -> EventsUpdate)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get ScoreTime
forall a. Serialize a => Get a
Serialize.get
        Get (Events -> EventsUpdate) -> Get Events -> Get EventsUpdate
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Events
forall a. Serialize a => Get a
Serialize.get

score_to_hex :: ScoreTime -> String
score_to_hex :: ScoreTime -> [Char]
score_to_hex = ShowS
pad ShowS -> (ScoreTime -> [Char]) -> ScoreTime -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word64 -> ShowS) -> [Char] -> Word64 -> [Char]
forall a b c. (a -> b -> c) -> b -> a -> c
flip Word64 -> ShowS
forall a. (Integral a, Show a) => a -> ShowS
Numeric.showHex [Char]
"" (Word64 -> [Char]) -> (ScoreTime -> Word64) -> ScoreTime -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Word64
Float.castDoubleToWord64
    (Double -> Word64) -> (ScoreTime -> Double) -> ScoreTime -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScoreTime -> Double
ScoreTime.to_double
    where pad :: ShowS
pad [Char]
s = Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate (Int
16 Int -> Int -> Int
forall a. Num a => a -> a -> a
- [Char] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
s) Char
'0' [Char] -> ShowS
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 = Text
-> IO (Either Text (State, Commit, [Text]))
-> IO (Either Text (State, Commit, [Text]))
forall a. Text -> IO (Either Text a) -> IO (Either Text a)
try_e Text
"load" (IO (Either Text (State, Commit, [Text]))
 -> IO (Either Text (State, Commit, [Text])))
-> IO (Either Text (State, Commit, [Text]))
-> IO (Either Text (State, Commit, [Text]))
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
    Either Text (State, Commit, [Text])
-> IO (Either Text (State, Commit, [Text]))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text (State, Commit, [Text])
 -> IO (Either Text (State, Commit, [Text])))
-> Either Text (State, Commit, [Text])
-> IO (Either Text (State, Commit, [Text]))
forall a b. (a -> b) -> a -> b
$ do
        State
state <- Dir -> Either Text State
undump Dir
dirs
        Map ViewId View
views <- Text
-> Either Text (Map ViewId View) -> Either Text (Map ViewId View)
forall a. Text -> Either Text a -> Either Text a
with_msg Text
"views" Either Text (Map ViewId View)
either_views
        (State, Commit, [Text]) -> Either Text (State, Commit, [Text])
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 = Text
-> IO (Either Text (Maybe LoadHistory))
-> IO (Either Text (Maybe LoadHistory))
forall a. Text -> IO (Either Text a) -> IO (Either Text a)
try_e Text
"load_previous_history" (IO (Either Text (Maybe LoadHistory))
 -> IO (Either Text (Maybe LoadHistory)))
-> IO (Either Text (Maybe LoadHistory))
-> IO (Either Text (Maybe LoadHistory))
forall a b. (a -> b) -> a -> b
$ do
    CommitData
commit_data <- [Char] -> Commit -> IO CommitData
Git.read_commit [Char]
repo Commit
commit
    case [Commit] -> Maybe Commit
forall a. [a] -> Maybe a
Seq.head (CommitData -> [Commit]
Git.commit_parents CommitData
commit_data) of
        Maybe Commit
Nothing -> Either Text (Maybe LoadHistory)
-> IO (Either Text (Maybe LoadHistory))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text (Maybe LoadHistory)
 -> IO (Either Text (Maybe LoadHistory)))
-> Either Text (Maybe LoadHistory)
-> IO (Either Text (Maybe LoadHistory))
forall a b. (a -> b) -> a -> b
$ Maybe LoadHistory -> Either Text (Maybe LoadHistory)
forall a b. b -> Either a b
Right Maybe LoadHistory
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 = Text
-> IO (Either Text (Maybe LoadHistory))
-> IO (Either Text (Maybe LoadHistory))
forall a. Text -> IO (Either Text a) -> IO (Either Text a)
try_e Text
"load_next_history" (IO (Either Text (Maybe LoadHistory))
 -> IO (Either Text (Maybe LoadHistory)))
-> IO (Either Text (Maybe LoadHistory))
-> IO (Either Text (Maybe LoadHistory))
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 Commit -> [Commit] -> Maybe Commit
forall {a}. Eq a => a -> [a] -> Maybe a
find_before Commit
commit [Commit]
commits of
        Maybe Commit
Nothing -> Either Text (Maybe LoadHistory)
-> IO (Either Text (Maybe LoadHistory))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text (Maybe LoadHistory)
 -> IO (Either Text (Maybe LoadHistory)))
-> Either Text (Maybe LoadHistory)
-> IO (Either Text (Maybe LoadHistory))
forall a b. (a -> b) -> a -> b
$ Maybe LoadHistory -> Either Text (Maybe LoadHistory)
forall a b. b -> Either a b
Right Maybe LoadHistory
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 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
x2 = a -> Maybe a
forall a. a -> Maybe a
Just a
x1
        | Bool
otherwise = a -> [a] -> Maybe a
find_before a
val (a
x2a -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs)
    find_before a
_ [a]
_ = Maybe 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 ([Char] -> IO [Text])
-> (CommitData -> [Char]) -> CommitData -> IO [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CommitData -> [Char]
Git.commit_text
        (CommitData -> IO [Text]) -> IO CommitData -> IO [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 (Commit -> Maybe Commit
forall a. a -> Maybe a
Just Commit
to_commit) State
state
    case Either Text (State, UiDamage)
result of
        Left Text
err -> Either Text (Maybe LoadHistory)
-> IO (Either Text (Maybe LoadHistory))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text (Maybe LoadHistory)
 -> IO (Either Text (Maybe LoadHistory)))
-> Either Text (Maybe LoadHistory)
-> IO (Either Text (Maybe LoadHistory))
forall a b. (a -> b) -> a -> b
$ Text -> Either Text (Maybe LoadHistory)
forall a b. a -> Either a b
Left Text
err
        Right (State
new_state, UiDamage
damage) -> Either Text (Maybe LoadHistory)
-> IO (Either Text (Maybe LoadHistory))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text (Maybe LoadHistory)
 -> IO (Either Text (Maybe LoadHistory)))
-> Either Text (Maybe LoadHistory)
-> IO (Either Text (Maybe LoadHistory))
forall a b. (a -> b) -> a -> b
$ Maybe LoadHistory -> Either Text (Maybe LoadHistory)
forall a b. b -> Either a b
Right (Maybe LoadHistory -> Either Text (Maybe LoadHistory))
-> Maybe LoadHistory -> Either Text (Maybe LoadHistory)
forall a b. (a -> b) -> a -> b
$ LoadHistory -> Maybe LoadHistory
forall a. a -> Maybe a
Just (LoadHistory -> Maybe LoadHistory)
-> LoadHistory -> Maybe LoadHistory
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
    Either Text (State, UiDamage) -> IO (Either Text (State, UiDamage))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text (State, UiDamage)
 -> IO (Either Text (State, UiDamage)))
-> Either Text (State, UiDamage)
-> IO (Either Text (State, UiDamage))
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) = Commit -> IO Commit
forall (m :: * -> *) a. Monad m => a -> m a
return Commit
commit
default_head [Char]
repo Maybe Commit
Nothing =
    IO Commit -> (Commit -> IO Commit) -> Maybe Commit -> IO Commit
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Char] -> IO Commit
forall a. [Char] -> IO a
Git.throw ([Char] -> IO Commit) -> [Char] -> IO Commit
forall a b. (a -> b) -> a -> b
$ [Char]
"repo with no HEAD commit: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> [Char]
show [Char]
repo)
        Commit -> IO Commit
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Commit -> IO Commit) -> IO (Maybe Commit) -> IO Commit
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] -> ([Char] -> Text) -> [[Char]] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Text
txt ([[Char]] -> [Text]) -> IO [[Char]] -> IO [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO [[Char]]
forall a. Read a => [Char] -> IO a
readIO [Char]
names
    [[Char]]
_ -> Text -> IO [Text]
forall a. Stack => Text -> a
errorStack (Text -> IO [Text]) -> Text -> IO [Text]
forall a b. (a -> b) -> a -> b
$ Text
"can't parse description: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
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 [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"\n" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Text] -> [Char]
forall a. Show a => a -> [Char]
show [Text]
names [Char] -> ShowS
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 =
    IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Bool -> IO ())
-> (Map ViewId View -> IO Bool) -> Map ViewId View -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Magic (Map ViewId View) -> [Char] -> Map ViewId View -> IO Bool
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 =
    Magic (Map ViewId View)
-> [Char] -> IO (Either UnserializeError (Map ViewId View))
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") IO (Either UnserializeError (Map ViewId View))
-> (Either UnserializeError (Map ViewId View)
    -> IO (Either Text (Map ViewId View)))
-> IO (Either Text (Map ViewId View))
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 ->
            Either Text (Map ViewId View) -> IO (Either Text (Map ViewId View))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text (Map ViewId View)
 -> IO (Either Text (Map ViewId View)))
-> Either Text (Map ViewId View)
-> IO (Either Text (Map ViewId View))
forall a b. (a -> b) -> a -> b
$ Map ViewId View -> Either Text (Map ViewId View)
forall a b. b -> Either a b
Right Map ViewId View
forall a. Monoid a => a
mempty
        Left UnserializeError
err -> Either Text (Map ViewId View) -> IO (Either Text (Map ViewId View))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text (Map ViewId View)
 -> IO (Either Text (Map ViewId View)))
-> Either Text (Map ViewId View)
-> IO (Either Text (Map ViewId View))
forall a b. (a -> b) -> a -> b
$ Text -> Either Text (Map ViewId View)
forall a b. a -> Either a b
Left (UnserializeError -> Text
forall a. Pretty a => a -> Text
pretty UnserializeError
err)
        Right Map ViewId View
views -> Either Text (Map ViewId View) -> IO (Either Text (Map ViewId View))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text (Map ViewId View)
 -> IO (Either Text (Map ViewId View)))
-> Either Text (Map ViewId View)
-> IO (Either Text (Map ViewId View))
forall a b. (a -> b) -> a -> b
$ Map ViewId View -> Either Text (Map ViewId View)
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) =
    Map BlockId Block -> [([Char], ByteString)]
forall id a.
(Ident id, Serialize a) =>
Map id a -> [([Char], ByteString)]
dump_map Map BlockId Block
blocks [([Char], ByteString)]
-> [([Char], ByteString)] -> [([Char], ByteString)]
forall a. [a] -> [a] -> [a]
++ Map TrackId Track -> [([Char], ByteString)]
forall id a.
(Ident id, Serialize a) =>
Map id a -> [([Char], ByteString)]
dump_map Map TrackId Track
tracks [([Char], ByteString)]
-> [([Char], ByteString)] -> [([Char], ByteString)]
forall a. [a] -> [a] -> [a]
++ Map RulerId Ruler -> [([Char], ByteString)]
forall id a.
(Ident id, Serialize a) =>
Map id a -> [([Char], ByteString)]
dump_map Map RulerId Ruler
rulers
    [([Char], ByteString)]
-> [([Char], ByteString)] -> [([Char], ByteString)]
forall a. [a] -> [a] -> [a]
++ [([Char]
"config", Config -> ByteString
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) <- Map id a -> [(id, a)]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map id a
m
    ([Char], ByteString) -> [([Char], ByteString)]
forall (m :: * -> *) a. Monad m => a -> m a
return (id -> [Char]
forall id. Ident id => id -> [Char]
id_to_path id
ident, a -> ByteString
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.
    ([Text] -> [Text])
-> ([Text], [Modification]) -> ([Text], [Modification])
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
Text.null)) (([Text], [Modification]) -> ([Text], [Modification]))
-> ([UiUpdate] -> ([Text], [Modification]))
-> [UiUpdate]
-> ([Text], [Modification])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Either Text Modification] -> ([Text], [Modification])
forall a b. [Either a b] -> ([a], [b])
Either.partitionEithers ([Either Text Modification] -> ([Text], [Modification]))
-> ([UiUpdate] -> [Either Text Modification])
-> [UiUpdate]
-> ([Text], [Modification])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UiUpdate -> Either Text Modification)
-> [UiUpdate] -> [Either Text Modification]
forall a b. (a -> b) -> [a] -> [b]
map UiUpdate -> Either Text Modification
forall {t}. Pretty t => Update t State -> Either Text Modification
mk
    where
    mk :: Update t State -> Either Text Modification
mk (Update.View {}) = Text -> Either Text Modification
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 <- BlockId -> Map BlockId Block -> Maybe 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) =
            Modification -> Either Text Modification
forall a b. b -> Either a b
Right (Modification -> Either Text Modification)
-> Modification -> Either Text Modification
forall a b. (a -> b) -> a -> b
$ [Char] -> ByteString -> Modification
Git.Add (BlockId -> [Char]
forall id. Ident id => id -> [Char]
id_to_path BlockId
block_id) (Block -> ByteString
forall a. Serialize a => a -> ByteString
Serialize.encode Block
block)
        | Bool
otherwise = Text -> Either Text Modification
forall a b. a -> Either a b
Left (Text -> Either Text Modification)
-> Text -> Either Text Modification
forall a b. (a -> b) -> a -> b
$ Text
"block_id: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Update t State -> Text
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 <- TrackId -> Map TrackId Track -> Maybe 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 ->
                    Modification -> Either Text Modification
forall a b. b -> Either a b
Right (Modification -> Either Text Modification)
-> Modification -> Either Text Modification
forall a b. (a -> b) -> a -> b
$ State -> TrackId -> ScoreTime -> ScoreTime -> Modification
dump_events State
state TrackId
track_id ScoreTime
start ScoreTime
end
                Track
_ -> Modification -> Either Text Modification
forall a b. b -> Either a b
Right (Modification -> Either Text Modification)
-> Modification -> Either Text Modification
forall a b. (a -> b) -> a -> b
$
                    [Char] -> ByteString -> Modification
Git.Add (TrackId -> [Char]
forall id. Ident id => id -> [Char]
id_to_path TrackId
track_id) (Track -> ByteString
forall a. Serialize a => a -> ByteString
Serialize.encode Track
track)
        | Bool
otherwise = Text -> Either Text Modification
forall a b. a -> Either a b
Left (Text -> Either Text Modification)
-> Text -> Either Text Modification
forall a b. (a -> b) -> a -> b
$ Text
"track_id: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Update t State -> Text
forall a. Pretty a => a -> Text
pretty Update t State
u
    mk (Update.Ruler RulerId
ruler_id)
        | Just Ruler
ruler <- RulerId -> Map RulerId Ruler -> Maybe 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) =
            Modification -> Either Text Modification
forall a b. b -> Either a b
Right (Modification -> Either Text Modification)
-> Modification -> Either Text Modification
forall a b. (a -> b) -> a -> b
$ [Char] -> ByteString -> Modification
Git.Add (RulerId -> [Char]
forall id. Ident id => id -> [Char]
id_to_path RulerId
ruler_id) (Ruler -> ByteString
forall a. Serialize a => a -> ByteString
Serialize.encode Ruler
ruler)
        | Bool
otherwise = Text -> Either Text Modification
forall a b. a -> Either a b
Left (Text -> Either Text Modification)
-> Text -> Either Text Modification
forall a b. (a -> b) -> a -> b
$ Text
"ruler_id: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> RulerId -> Text
forall a. Pretty a => a -> Text
pretty RulerId
ruler_id
    mk (Update.State State
update) = case State
update of
        Update.Config Config
config ->
            Modification -> Either Text Modification
forall a b. b -> Either a b
Right (Modification -> Either Text Modification)
-> Modification -> Either Text Modification
forall a b. (a -> b) -> a -> b
$ [Char] -> ByteString -> Modification
Git.Add [Char]
"config" (Config -> ByteString
forall a. Serialize a => a -> ByteString
Serialize.encode Config
config)
        Update.CreateBlock BlockId
block_id Block
block ->
            Modification -> Either Text Modification
forall a b. b -> Either a b
Right (Modification -> Either Text Modification)
-> Modification -> Either Text Modification
forall a b. (a -> b) -> a -> b
$ [Char] -> ByteString -> Modification
Git.Add (BlockId -> [Char]
forall id. Ident id => id -> [Char]
id_to_path BlockId
block_id) (Block -> ByteString
forall a. Serialize a => a -> ByteString
Serialize.encode Block
block)
        Update.DestroyBlock BlockId
block_id ->
            Modification -> Either Text Modification
forall a b. b -> Either a b
Right (Modification -> Either Text Modification)
-> Modification -> Either Text Modification
forall a b. (a -> b) -> a -> b
$ [Char] -> Modification
Git.Remove (BlockId -> [Char]
forall id. Ident id => id -> [Char]
id_to_path BlockId
block_id)
        Update.CreateTrack TrackId
track_id Track
track ->
            Modification -> Either Text Modification
forall a b. b -> Either a b
Right (Modification -> Either Text Modification)
-> Modification -> Either Text Modification
forall a b. (a -> b) -> a -> b
$ [Char] -> ByteString -> Modification
Git.Add (TrackId -> [Char]
forall id. Ident id => id -> [Char]
id_to_path TrackId
track_id) (Track -> ByteString
forall a. Serialize a => a -> ByteString
Serialize.encode Track
track)
        Update.DestroyTrack TrackId
track_id ->
            Modification -> Either Text Modification
forall a b. b -> Either a b
Right (Modification -> Either Text Modification)
-> Modification -> Either Text Modification
forall a b. (a -> b) -> a -> b
$ [Char] -> Modification
Git.Remove (TrackId -> [Char]
forall id. Ident id => id -> [Char]
id_to_path TrackId
track_id)
        Update.CreateRuler RulerId
ruler_id Ruler
ruler ->
            Modification -> Either Text Modification
forall a b. b -> Either a b
Right (Modification -> Either Text Modification)
-> Modification -> Either Text Modification
forall a b. (a -> b) -> a -> b
$ [Char] -> ByteString -> Modification
Git.Add (RulerId -> [Char]
forall id. Ident id => id -> [Char]
id_to_path RulerId
ruler_id) (Ruler -> ByteString
forall a. Serialize a => a -> ByteString
Serialize.encode Ruler
ruler)
        Update.DestroyRuler RulerId
ruler_id ->
            Modification -> Either Text Modification
forall a b. b -> Either a b
Right (Modification -> Either Text Modification)
-> Modification -> Either Text Modification
forall a b. (a -> b) -> a -> b
$ [Char] -> Modification
Git.Remove (RulerId -> [Char]
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 <- (Id -> BlockId) -> Dir -> Either Text (Map BlockId Block)
forall a id.
(Serialize a, Ord id) =>
(Id -> id) -> Dir -> Either Text (Map id a)
undump_map Id -> BlockId
Id.BlockId (Dir -> Either Text (Map BlockId Block))
-> Either Text Dir -> Either Text (Map BlockId Block)
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 <- (Id -> TrackId) -> Dir -> Either Text (Map TrackId Track)
forall a id.
(Serialize a, Ord id) =>
(Id -> id) -> Dir -> Either Text (Map id a)
undump_map Id -> TrackId
Id.TrackId (Dir -> Either Text (Map TrackId Track))
-> Either Text Dir -> Either Text (Map TrackId Track)
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 <- (Id -> RulerId) -> Dir -> Either Text (Map RulerId Ruler)
forall a id.
(Serialize a, Ord id) =>
(Id -> id) -> Dir -> Either Text (Map id a)
undump_map Id -> RulerId
Id.RulerId (Dir -> Either Text (Map RulerId Ruler))
-> Either Text Dir -> Either Text (Map RulerId Ruler)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Char] -> Either Text Dir
get_dir [Char]
"rulers"
    Config
config <- Text -> ByteString -> Either Text Config
forall a. Serialize a => Text -> ByteString -> Either Text a
decode Text
"config" (ByteString -> Either Text Config)
-> Either Text ByteString -> Either Text Config
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Char] -> Either Text ByteString
get_file [Char]
"config"
    State -> Either Text State
forall (m :: * -> *) a. Monad m => a -> m a
return (State -> Either Text State) -> State -> Either Text State
forall a b. (a -> b) -> a -> b
$ Map ViewId View
-> Map BlockId Block
-> Map TrackId Track
-> Map RulerId Ruler
-> Config
-> State
Ui.State Map ViewId View
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 [Char] -> Dir -> Maybe File
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup [Char]
name Dir
dir of
        Maybe File
Nothing -> Dir -> Either Text Dir
forall (m :: * -> *) a. Monad m => a -> m a
return Dir
forall k a. Map k a
Map.empty
        Just (Git.File ByteString
_) -> Text -> Either Text Dir
forall a b. a -> Either a b
Left (Text -> Either Text Dir) -> Text -> Either Text Dir
forall a b. (a -> b) -> a -> b
$ Text
"expected dir but got file: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
forall a. Show a => a -> Text
showt [Char]
name
        Just (Git.Dir Dir
dir) -> Dir -> Either Text Dir
forall (m :: * -> *) a. Monad m => a -> m a
return Dir
dir
    get_file :: [Char] -> Either Text ByteString
get_file [Char]
name = case [Char] -> Dir -> Maybe File
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup [Char]
name Dir
dir of
        Maybe File
Nothing -> Text -> Either Text ByteString
forall a b. a -> Either a b
Left (Text -> Either Text ByteString) -> Text -> Either Text ByteString
forall a b. (a -> b) -> a -> b
$ Text
"file not found: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
forall a. Show a => a -> Text
showt [Char]
name
        Just (Git.Dir Dir
_) -> Text -> Either Text ByteString
forall a b. a -> Either a b
Left (Text -> Either Text ByteString) -> Text -> Either Text ByteString
forall a b. (a -> b) -> a -> b
$ Text
"expected file but got dir: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
forall a. Show a => a -> Text
showt [Char]
name
        Just (Git.File ByteString
bytes) -> ByteString -> Either Text ByteString
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 =
    [(id, a)] -> Map id a
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(id, a)] -> Map id a)
-> ([[(id, a)]] -> [(id, a)]) -> [[(id, a)]] -> Map id a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[(id, a)]] -> [(id, a)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[(id, a)]] -> Map id a)
-> Either Text [[(id, a)]] -> Either Text (Map id a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (([Char], File) -> Either Text [(id, a)])
-> [([Char], File)] -> Either Text [[(id, a)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ([Char], File) -> Either Text [(id, a)]
forall {a}. Serialize a => ([Char], File) -> Either Text [(id, a)]
dir_subs (Dir -> [([Char], File)]
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
_) =
        Text -> Either Text [(id, a)]
forall a b. a -> Either a b
Left (Text -> Either Text [(id, a)]) -> Text -> Either Text [(id, a)]
forall a b. (a -> b) -> a -> b
$ Text
"expected dir but got file: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
forall a. Show a => a -> Text
showt [Char]
name
    dir_subs ([Char]
name, Git.Dir Dir
subs) = (([Char], File) -> Either Text (id, a))
-> [([Char], File)] -> Either Text [(id, a)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ([Char] -> ([Char], File) -> Either Text (id, a)
forall {a}.
Serialize a =>
[Char] -> ([Char], File) -> Either Text (id, a)
undump_file [Char]
name) (Dir -> [([Char], File)]
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
_) =
        Text -> Either Text (id, a)
forall a b. a -> Either a b
Left (Text -> Either Text (id, a)) -> Text -> Either Text (id, a)
forall a b. (a -> b) -> a -> b
$ Text
"expected file but got dir: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
forall a. Show a => a -> Text
showt [Char]
name
    undump_file [Char]
ns ([Char]
name, Git.File ByteString
bytes) =
        (,) ((Id -> id) -> [Char] -> [Char] -> id
forall id. (Id -> id) -> [Char] -> [Char] -> id
path_to_id Id -> id
mkid [Char]
ns [Char]
name) (a -> (id, a)) -> Either Text a -> Either Text (id, a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> ByteString -> Either Text a
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 = ((State, UiDamage)
 -> Modification -> Either Text (State, UiDamage))
-> (State, UiDamage)
-> [Modification]
-> Either Text (State, UiDamage)
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, UiDamage
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] -> [Char]
-> [Char]
-> (Id -> BlockId)
-> Lens State (Map BlockId Block)
-> Either Text (State, UiDamage)
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] -> [Char]
-> [Char]
-> (Id -> TrackId)
-> Lens State (Map TrackId Track)
-> Either Text (State, UiDamage)
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] -> [Char]
-> [Char]
-> (Id -> RulerId)
-> Lens State (Map RulerId Ruler)
-> Either Text (State, UiDamage)
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]]
_ -> Text -> Either Text (State, UiDamage)
forall a b. a -> Either a b
Left (Text -> Either Text (State, UiDamage))
-> Text -> Either Text (State, UiDamage)
forall a b. (a -> b) -> a -> b
$ Text
"unknown file deleted: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
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 = (Id -> k) -> [Char] -> [Char] -> k
forall id. (Id -> id) -> [Char] -> [Char] -> id
path_to_id Id -> k
mkid [Char]
ns [Char]
name
            Map k a
vals <- k -> Map k a -> Either Text (Map k a)
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 Lens State (Map k a) -> State -> Map k a
forall f a. Lens f a -> f -> a
#$ State
state)
            (State, UiDamage) -> Either Text (State, UiDamage)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Lens State (Map k a)
lens Lens State (Map k a) -> Map k a -> State -> State
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) (State -> (State, UiDamage))
-> Either Text State -> Either Text (State, UiDamage)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char]
-> [Char]
-> (Id -> BlockId)
-> Lens State (Map BlockId Block)
-> Either Text State
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 <- [Char]
-> [Char]
-> (Id -> TrackId)
-> Lens State (Map TrackId Track)
-> Either Text State
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 = (Id -> TrackId) -> [Char] -> [Char] -> TrackId
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
            (State, UiDamage) -> Either Text (State, UiDamage)
forall (m :: * -> *) a. Monad m => a -> m a
return (State
state_to, UiDamage
event_updates UiDamage -> UiDamage -> UiDamage
forall a. Semigroup a => a -> a -> a
<> UiDamage
update)
        [[Char]
"rulers", [Char]
ns, [Char]
name] -> do
            State
state_to <- [Char]
-> [Char]
-> (Id -> RulerId)
-> Lens State (Map RulerId Ruler)
-> Either Text State
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 = RulerId -> Set RulerId
forall a. a -> Set a
Set.singleton (RulerId -> Set RulerId) -> RulerId -> Set RulerId
forall a b. (a -> b) -> a -> b
$ (Id -> RulerId) -> [Char] -> [Char] -> RulerId
forall id. (Id -> id) -> [Char] -> [Char] -> id
path_to_id Id -> RulerId
Id.RulerId [Char]
ns [Char]
name
            (State, UiDamage) -> Either Text (State, UiDamage)
forall (m :: * -> *) a. Monad m => a -> m a
return (State
state_to, UiDamage
forall a. Monoid a => a
mempty { _rulers :: Set RulerId
Update._rulers = Set RulerId
rid } UiDamage -> UiDamage -> UiDamage
forall a. Semigroup a => a -> a -> a
<> UiDamage
update)
        [[Char]
"config"] -> do
            Config
val <- Text -> ByteString -> Either Text Config
forall a. Serialize a => Text -> ByteString -> Either Text a
decode ([Char] -> Text
txt [Char]
path) ByteString
bytes
            (State, UiDamage) -> Either Text (State, UiDamage)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Lens State Config
Ui.config Lens State Config -> Config -> State -> State
forall f a. Lens f a -> a -> f -> f
#= Config
val) State
state, UiDamage
update)
        [[Char]]
_ -> Text -> Either Text (State, UiDamage)
forall a b. a -> Either a b
Left (Text -> Either Text (State, UiDamage))
-> Text -> Either Text (State, UiDamage)
forall a b. (a -> b) -> a -> b
$ Text
"unknown file modified: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
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 = (Id -> k) -> [Char] -> [Char] -> k
forall id. (Id -> id) -> [Char] -> [Char] -> id
path_to_id Id -> k
mkid [Char]
ns [Char]
name
            a
val <- Text -> ByteString -> Either Text a
forall a. Serialize a => Text -> ByteString -> Either Text a
decode ([Char] -> Text
txt [Char]
path) ByteString
bytes
            State -> Either Text State
forall (m :: * -> *) a. Monad m => a -> m a
return (State -> Either Text State) -> State -> Either Text State
forall a b. (a -> b) -> a -> b
$ (Lens State (Map k a)
lens Lens State (Map k a) -> (Map k a -> Map k a) -> State -> State
forall f a. Lens f a -> (a -> a) -> f -> f
%= k -> a -> Map k a -> Map k a
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 = [Char] -> BlockId -> [Char]
forall a. Ident a => [Char] -> a -> [Char]
make_id_path [Char]
"blocks"
instance Ident TrackId where id_to_path :: TrackId -> [Char]
id_to_path = [Char] -> TrackId -> [Char]
forall a. Ident a => [Char] -> a -> [Char]
make_id_path [Char]
"tracks"
instance Ident RulerId where id_to_path :: RulerId -> [Char]
id_to_path = [Char] -> RulerId -> [Char]
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 (a -> Id
forall a. Ident a => a -> Id
Id.unpack_id a
id)
    nsdir :: Text
nsdir
        | Namespace
ns Namespace -> Namespace -> Bool
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 [Char] -> [Char] -> Bool
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 -> Maybe Commit -> IO (Maybe Commit)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Commit -> IO (Maybe Commit))
-> Maybe Commit -> IO (Maybe Commit)
forall a b. (a -> b) -> a -> b
$ Commit -> Maybe Commit
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 <- IO a -> IO (Either GitException a)
forall e a. Exception e => IO a -> IO (Either e a)
Exception.try IO a
io
    Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> IO (Maybe a)) -> Maybe a -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ case Either GitException a
result of
        Left (Git.GitException [Char]
_) -> Maybe a
forall a. Maybe a
Nothing
        Right a
val -> a -> Maybe a
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 <- IO a -> IO (Either GitException a)
forall e a. Exception e => IO a -> IO (Either e a)
Exception.try IO a
io
    Either Text a -> IO (Either Text a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text a -> IO (Either Text a))
-> Either Text a -> IO (Either Text a)
forall a b. (a -> b) -> a -> b
$ case Either GitException a
result of
        Left (Git.GitException [Char]
err) -> Text -> Either Text a
forall a b. a -> Either a b
Left (Text -> Either Text a) -> Text -> Either Text a
forall a b. (a -> b) -> a -> b
$ Text
caller Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
txt [Char]
err
        Right a
val -> a -> Either Text a
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 <- IO (Either Text a) -> IO (Either GitException (Either Text a))
forall e a. Exception e => IO a -> IO (Either e a)
Exception.try IO (Either Text a)
io
    Either Text a -> IO (Either Text a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text a -> IO (Either Text a))
-> Either Text a -> IO (Either Text a)
forall a b. (a -> b) -> a -> b
$ case Either GitException (Either Text a)
result of
        Left (Git.GitException [Char]
err) -> Text -> Either Text a
forall a b. a -> Either a b
Left (Text -> Either Text a) -> Text -> Either Text a
forall a b. (a -> b) -> a -> b
$ Text
caller Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
txt [Char]
err
        Right (Left Text
err) -> Text -> Either Text a
forall a b. a -> Either a b
Left (Text -> Either Text a) -> Text -> Either Text a
forall a b. (a -> b) -> a -> b
$ Text
caller Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
err
        Right (Right a
val) -> a -> Either Text a
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
    | k -> Map k a -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member k
k Map k a
m = Map k a -> Either Text (Map k a)
forall a b. b -> Either a b
Right (Map k a -> Either Text (Map k a))
-> Map k a -> Either Text (Map k a)
forall a b. (a -> b) -> a -> b
$ k -> Map k a -> Map k a
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete k
k Map k a
m
    | Bool
otherwise = Text -> Either Text (Map k a)
forall a b. a -> Either a b
Left (Text -> Either Text (Map k a)) -> Text -> Either Text (Map k a)
forall a b. (a -> b) -> a -> b
$ Text
"deleted key " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> k -> Text
forall a. Show a => a -> Text
showt k
k Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" not present: "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [k] -> Text
forall a. Show a => a -> Text
showt (Map k a -> [k]
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 = Text -> Either Text a -> Either Text a
forall a. Text -> Either Text a -> Either Text a
with_msg Text
msg (Either Text a -> Either Text a)
-> (ByteString -> Either Text a) -> ByteString -> Either Text a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> Text) -> Either [Char] a -> Either Text a
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first [Char] -> Text
txt (Either [Char] a -> Either Text a)
-> (ByteString -> Either [Char] a) -> ByteString -> Either Text a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either [Char] a
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) = Text -> Either Text a
forall a b. a -> Either a b
Left (Text -> Either Text a) -> Text -> Either Text a
forall a b. (a -> b) -> a -> b
$ Text
msg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
err
with_msg Text
_ (Right a
val) = a -> Either Text a
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 = (IOError -> IO (Either Text User))
-> IO (Either Text User) -> IO (Either Text User)
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
Exception.handle IOError -> IO (Either Text User)
forall {m :: * -> *} {b}. Monad m => IOError -> m (Either Text b)
handle (IO (Either Text User) -> IO (Either Text User))
-> IO (Either Text User) -> IO (Either Text User)
forall a b. (a -> b) -> a -> b
$ do
    [Text]
lines <- Text -> [Text]
Text.lines (Text -> [Text]) -> ([Char] -> Text) -> [Char] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
txt ([Char] -> [Text]) -> IO [Char] -> IO [Text]
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 (Text -> Text) -> Map Text Text -> Map Text Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Text, Text)] -> Map Text Text
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ((Text -> (Text, Text)) -> [Text] -> [(Text, Text)]
forall a b. (a -> b) -> [a] -> [b]
map ((Char -> Bool) -> Text -> (Text, Text)
Text.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
' ')) [Text]
lines)
    Either Text User -> IO (Either Text User)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text User -> IO (Either Text User))
-> Either Text User -> IO (Either Text User)
forall a b. (a -> b) -> a -> b
$ case (Text -> Map Text Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
"user.name" Map Text Text
m, Text -> Map Text Text -> Maybe Text
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) ->
                User -> Either Text User
forall a b. b -> Either a b
Right (User -> Either Text User) -> User -> Either Text User
forall a b. (a -> b) -> a -> b
$ Text -> Text -> User
SaveGitT.User Text
name Text
email
        (Maybe Text, Maybe Text)
_ -> Text -> Either Text User
forall a b. a -> Either a b
Left (Text -> Either Text User) -> Text -> Either Text User
forall a b. (a -> b) -> a -> b
$ Text
"user.name and user.email not set in git config output: "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
forall a. Show a => a -> Text
showt [Text]
lines
    where
    handle :: IOError -> m (Either Text b)
handle IOError
exc = Either Text b -> m (Either Text b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text b -> m (Either Text b))
-> Either Text b -> m (Either Text b)
forall a b. (a -> b) -> a -> b
$
        Text -> Either Text b
forall a b. a -> Either a b
Left (Text -> Either Text b) -> Text -> Either Text b
forall a b. (a -> b) -> a -> b
$ Text
"error getting git config: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> IOError -> Text
forall a. Show a => a -> Text
showt (IOError
exc :: IO.Error.IOError)