-- 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 StrictData #-}
{-# LANGUAGE NamedFieldPuns #-}
{- | Updates are diffs against Ui.State and are used in a number of contexts.
    They are produced by "Ui.Diff".  The different uses all require slightly
    different data, and I capture the major differences in separate types.
-}
module Ui.Update where
import qualified Control.DeepSeq as DeepSeq
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified GHC.Generics as Generics

import qualified Util.Maps as Maps
import qualified Util.Pretty as Pretty
import qualified Util.Ranges as Ranges
import qualified Util.Rect as Rect
import qualified Util.Seq as Seq

import qualified Ui.Block as Block
import qualified Ui.Color as Color
import qualified Ui.Id as Id
import qualified Ui.Ruler as Ruler
import qualified Ui.Sel as Sel
import qualified Ui.Skeleton as Skeleton
import qualified Ui.Track as Track
import qualified Ui.Types as Types
import qualified Ui.UiConfig as UiConfig
import qualified Ui.Zoom as Zoom

import           Global
import           Types


-- | 'DisplayUpdate's are sent to the UI to update the windows.  Since the UI
-- only has Views, and has a lower level version of tracks, this includes
-- only updates that directly affect display.
type DisplayUpdate = Update Block.DisplayTrack ()

-- | 'UiUpdate's reflect all changes to the underlying UI state.  They're
-- used for incremental save, and by the deriver to determine ScoreDamage.
type UiUpdate = Update Block.Track State

-- | This collects damaged Ui.State elements, manually added by the various
-- Ui functions.  I use "Ui.Diff" to get the exact changes, but it's too
-- slow to compare the entire Ui.State, so UiDamage is used to restrict the
-- diff to just parts that may have changed.
--
-- There are also a few mutations that correspond directly 'UiUpdate's which
-- I just emit directly rather than relying on diff.  Those are converted from
-- UiDamage by 'to_ui'.
--
-- TODO The indirection for BringToFront, TitleFocus, seems a bit fussy.  Can I
-- just store some Updates in here?
data UiDamage = UiDamage {
    UiDamage -> Set ViewId
_views :: Set ViewId
    -- | This means there may have been any change at all inside these blocks,
    -- and Diff should check for them.  It doesn't mean it's an interesting
    -- change, that's up to Diff to decide!
    , UiDamage -> Set BlockId
_blocks :: Set BlockId
    -- | This specifically means there was change on the given tracks.
    , UiDamage -> Map TrackId (Ranges TrackTime)
_tracks :: Map TrackId (Ranges.Ranges TrackTime)
    , UiDamage -> Set RulerId
_rulers :: Set RulerId
    , UiDamage -> Set ViewId
_bring_to_front :: Set ViewId
    -- | If the TrackNum is set, set keyboard focus on that track's title.
    -- Otherwise, focus on the block title.
    , UiDamage -> Maybe (ViewId, Maybe Int)
_title_focus :: Maybe (ViewId, Maybe TrackNum)
    -- | This is purely to trigger 'is_score_damage'.
    -- TODO: Ui.state_config changes should do this so Diff.score_changed
    -- dosen't need to compare UiConfig.Config each time, but modification
    -- happens through lenses...
    , UiDamage -> Bool
_score_damage :: Bool
    } deriving (UiDamage -> UiDamage -> Bool
(UiDamage -> UiDamage -> Bool)
-> (UiDamage -> UiDamage -> Bool) -> Eq UiDamage
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UiDamage -> UiDamage -> Bool
$c/= :: UiDamage -> UiDamage -> Bool
== :: UiDamage -> UiDamage -> Bool
$c== :: UiDamage -> UiDamage -> Bool
Eq, Int -> UiDamage -> ShowS
[UiDamage] -> ShowS
UiDamage -> String
(Int -> UiDamage -> ShowS)
-> (UiDamage -> String) -> ([UiDamage] -> ShowS) -> Show UiDamage
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UiDamage] -> ShowS
$cshowList :: [UiDamage] -> ShowS
show :: UiDamage -> String
$cshow :: UiDamage -> String
showsPrec :: Int -> UiDamage -> ShowS
$cshowsPrec :: Int -> UiDamage -> ShowS
Show, (forall x. UiDamage -> Rep UiDamage x)
-> (forall x. Rep UiDamage x -> UiDamage) -> Generic UiDamage
forall x. Rep UiDamage x -> UiDamage
forall x. UiDamage -> Rep UiDamage x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep UiDamage x -> UiDamage
$cfrom :: forall x. UiDamage -> Rep UiDamage x
Generics.Generic)

instance Semigroup UiDamage where
    <> :: UiDamage -> UiDamage -> UiDamage
(<>)    (UiDamage Set ViewId
v1 Set BlockId
b1 Map TrackId (Ranges TrackTime)
t1 Set RulerId
r1 Set ViewId
bring1 Maybe (ViewId, Maybe Int)
title1 Bool
sd1)
            (UiDamage Set ViewId
v2 Set BlockId
b2 Map TrackId (Ranges TrackTime)
t2 Set RulerId
r2 Set ViewId
bring2 Maybe (ViewId, Maybe Int)
title2 Bool
sd2) =
        Set ViewId
-> Set BlockId
-> Map TrackId (Ranges TrackTime)
-> Set RulerId
-> Set ViewId
-> Maybe (ViewId, Maybe Int)
-> Bool
-> UiDamage
UiDamage (Set ViewId
v1Set ViewId -> Set ViewId -> Set ViewId
forall a. Semigroup a => a -> a -> a
<>Set ViewId
v2) (Set BlockId
b1Set BlockId -> Set BlockId -> Set BlockId
forall a. Semigroup a => a -> a -> a
<>Set BlockId
b2) (Map TrackId (Ranges TrackTime)
-> Map TrackId (Ranges TrackTime) -> Map TrackId (Ranges TrackTime)
forall k a. (Ord k, Monoid a) => Map k a -> Map k a -> Map k a
Maps.mappend Map TrackId (Ranges TrackTime)
t1 Map TrackId (Ranges TrackTime)
t2) (Set RulerId
r1Set RulerId -> Set RulerId -> Set RulerId
forall a. Semigroup a => a -> a -> a
<>Set RulerId
r2)
            (Set ViewId
bring1Set ViewId -> Set ViewId -> Set ViewId
forall a. Semigroup a => a -> a -> a
<>Set ViewId
bring2) (Maybe (ViewId, Maybe Int)
title1Maybe (ViewId, Maybe Int)
-> Maybe (ViewId, Maybe Int) -> Maybe (ViewId, Maybe Int)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>Maybe (ViewId, Maybe Int)
title2) (Bool
sd1Bool -> Bool -> Bool
||Bool
sd2)

instance Monoid UiDamage where
    mempty :: UiDamage
mempty = Set ViewId
-> Set BlockId
-> Map TrackId (Ranges TrackTime)
-> Set RulerId
-> Set ViewId
-> Maybe (ViewId, Maybe Int)
-> Bool
-> UiDamage
UiDamage Set ViewId
forall a. Monoid a => a
mempty Set BlockId
forall a. Monoid a => a
mempty Map TrackId (Ranges TrackTime)
forall a. Monoid a => a
mempty Set RulerId
forall a. Monoid a => a
mempty Set ViewId
forall a. Monoid a => a
mempty Maybe (ViewId, Maybe Int)
forall a. Maybe a
Nothing Bool
False
    mappend :: UiDamage -> UiDamage -> UiDamage
mappend = UiDamage -> UiDamage -> UiDamage
forall a. Semigroup a => a -> a -> a
(<>)

instance Pretty UiDamage where format :: UiDamage -> Doc
format = UiDamage -> Doc
forall a. (PrettyG (Rep a), Generic a) => a -> Doc
Pretty.formatG_

view_damage :: ViewId -> UiDamage
view_damage :: ViewId -> UiDamage
view_damage ViewId
id = UiDamage
forall a. Monoid a => a
mempty { _views :: Set ViewId
_views = ViewId -> Set ViewId
forall a. a -> Set a
Set.singleton ViewId
id }

block_damage :: BlockId -> UiDamage
block_damage :: BlockId -> UiDamage
block_damage BlockId
id = UiDamage
forall a. Monoid a => a
mempty { _blocks :: Set BlockId
_blocks = BlockId -> Set BlockId
forall a. a -> Set a
Set.singleton BlockId
id }

track_damage :: TrackId -> Ranges.Ranges TrackTime -> UiDamage
track_damage :: TrackId -> Ranges TrackTime -> UiDamage
track_damage TrackId
id Ranges TrackTime
range = UiDamage
forall a. Monoid a => a
mempty { _tracks :: Map TrackId (Ranges TrackTime)
_tracks = TrackId -> Ranges TrackTime -> Map TrackId (Ranges TrackTime)
forall k a. k -> a -> Map k a
Map.singleton TrackId
id Ranges TrackTime
range }

ruler_damage :: RulerId -> UiDamage
ruler_damage :: RulerId -> UiDamage
ruler_damage RulerId
id = UiDamage
forall a. Monoid a => a
mempty { _rulers :: Set RulerId
_rulers = RulerId -> Set RulerId
forall a. a -> Set a
Set.singleton RulerId
id }

data Update t u =
    View ViewId View
    | Block BlockId (Block t)
    | Track TrackId Track
    -- | Since I expect rulers to be changed infrequently, the only kind of
    -- ruler update is a full update.
    | Ruler RulerId
    | State u
    deriving (Update t u -> Update t u -> Bool
(Update t u -> Update t u -> Bool)
-> (Update t u -> Update t u -> Bool) -> Eq (Update t u)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall t u. (Eq t, Eq u) => Update t u -> Update t u -> Bool
/= :: Update t u -> Update t u -> Bool
$c/= :: forall t u. (Eq t, Eq u) => Update t u -> Update t u -> Bool
== :: Update t u -> Update t u -> Bool
$c== :: forall t u. (Eq t, Eq u) => Update t u -> Update t u -> Bool
Eq, Int -> Update t u -> ShowS
[Update t u] -> ShowS
Update t u -> String
(Int -> Update t u -> ShowS)
-> (Update t u -> String)
-> ([Update t u] -> ShowS)
-> Show (Update t u)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall t u. (Show t, Show u) => Int -> Update t u -> ShowS
forall t u. (Show t, Show u) => [Update t u] -> ShowS
forall t u. (Show t, Show u) => Update t u -> String
showList :: [Update t u] -> ShowS
$cshowList :: forall t u. (Show t, Show u) => [Update t u] -> ShowS
show :: Update t u -> String
$cshow :: forall t u. (Show t, Show u) => Update t u -> String
showsPrec :: Int -> Update t u -> ShowS
$cshowsPrec :: forall t u. (Show t, Show u) => Int -> Update t u -> ShowS
Show)

data View =
    CreateView
    | DestroyView
    | ViewSize Rect.Rect
    | Status (Map (Int, Text) Text) Color.Color -- ^ background color
    | TrackScroll Types.Width
    | Zoom Zoom.Zoom
    | Selection Sel.Num (Maybe Sel.Selection)
    -- | Bring the window to the front.  Unlike most other updates, this is
    -- recorded directly and is not reflected in Ui.State.
    | BringToFront
    -- | Similar to BringToFront, but sets keyboard focus in a track title.
    -- If the TrackNum is not given, focus on the block title.
    | TitleFocus (Maybe TrackNum)
    deriving (View -> View -> Bool
(View -> View -> Bool) -> (View -> View -> Bool) -> Eq View
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: View -> View -> Bool
$c/= :: View -> View -> Bool
== :: View -> View -> Bool
$c== :: View -> View -> Bool
Eq, Int -> View -> ShowS
[View] -> ShowS
View -> String
(Int -> View -> ShowS)
-> (View -> String) -> ([View] -> ShowS) -> Show View
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [View] -> ShowS
$cshowList :: [View] -> ShowS
show :: View -> String
$cshow :: View -> String
showsPrec :: Int -> View -> ShowS
$cshowsPrec :: Int -> View -> ShowS
Show)

data Block t =
    BlockTitle Text
    | BlockConfig Block.Config
    -- | The second is the \"integrate skeleton\", which is drawn in the same
    -- place.  It could be Skeleton too, but since it never was a skeleton it
    -- seems pointless to convert it to one just so it can be flattened again.
    -- Arguably it's the first arg which should be edges, but at least this way
    -- the two args can't be mixed up.
    | BlockSkeleton Skeleton.Skeleton [(Color.Color, [(TrackNum, TrackNum)])]
    | RemoveTrack TrackNum
    | InsertTrack TrackNum t
    -- | Unlike 'Track', these settings are local to the block, not global to
    -- this track in all its blocks.
    | BlockTrack TrackNum t
    deriving (Block t -> Block t -> Bool
(Block t -> Block t -> Bool)
-> (Block t -> Block t -> Bool) -> Eq (Block t)
forall t. Eq t => Block t -> Block t -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Block t -> Block t -> Bool
$c/= :: forall t. Eq t => Block t -> Block t -> Bool
== :: Block t -> Block t -> Bool
$c== :: forall t. Eq t => Block t -> Block t -> Bool
Eq, Int -> Block t -> ShowS
[Block t] -> ShowS
Block t -> String
(Int -> Block t -> ShowS)
-> (Block t -> String) -> ([Block t] -> ShowS) -> Show (Block t)
forall t. Show t => Int -> Block t -> ShowS
forall t. Show t => [Block t] -> ShowS
forall t. Show t => Block t -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Block t] -> ShowS
$cshowList :: forall t. Show t => [Block t] -> ShowS
show :: Block t -> String
$cshow :: forall t. Show t => Block t -> String
showsPrec :: Int -> Block t -> ShowS
$cshowsPrec :: forall t. Show t => Int -> Block t -> ShowS
Show)

data Track =
    -- | Low pos, high pos.
    TrackEvents ScoreTime ScoreTime
    -- | Update the entire track.
    | TrackAllEvents
    | TrackTitle Text
    | TrackBg Color.Color
    | TrackRender Track.RenderConfig
    deriving (Track -> Track -> Bool
(Track -> Track -> Bool) -> (Track -> Track -> Bool) -> Eq Track
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Track -> Track -> Bool
$c/= :: Track -> Track -> Bool
== :: Track -> Track -> Bool
$c== :: Track -> Track -> Bool
Eq, Int -> Track -> ShowS
[Track] -> ShowS
Track -> String
(Int -> Track -> ShowS)
-> (Track -> String) -> ([Track] -> ShowS) -> Show Track
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Track] -> ShowS
$cshowList :: [Track] -> ShowS
show :: Track -> String
$cshow :: Track -> String
showsPrec :: Int -> Track -> ShowS
$cshowsPrec :: Int -> Track -> ShowS
Show)

-- | These are updates to 'Ui.Ui.State' that have no UI presence.
data State =
    Config UiConfig.Config
    | CreateBlock BlockId Block.Block
    | DestroyBlock BlockId
    | CreateTrack TrackId Track.Track
    | DestroyTrack TrackId
    | CreateRuler RulerId Ruler.Ruler
    | DestroyRuler RulerId
    deriving (State -> State -> Bool
(State -> State -> Bool) -> (State -> State -> Bool) -> Eq State
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: State -> State -> Bool
$c/= :: State -> State -> Bool
== :: State -> State -> Bool
$c== :: State -> State -> Bool
Eq, Int -> State -> ShowS
[State] -> ShowS
State -> String
(Int -> State -> ShowS)
-> (State -> String) -> ([State] -> ShowS) -> Show State
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [State] -> ShowS
$cshowList :: [State] -> ShowS
show :: State -> String
$cshow :: State -> String
showsPrec :: Int -> State -> ShowS
$cshowsPrec :: Int -> State -> ShowS
Show)

instance DeepSeq.NFData (Update t u) where
    rnf :: Update t u -> ()
rnf Update t u
update = case Update t u
update of
        View ViewId
view_id View
update -> ViewId
view_id ViewId -> () -> ()
`seq` View
update View -> () -> ()
`seq` ()
        Block BlockId
block_id Block t
update -> BlockId
block_id BlockId -> () -> ()
`seq` Block t
update Block t -> () -> ()
`seq` ()
        Track TrackId
track_id Track
update -> TrackId
track_id TrackId -> () -> ()
`seq` Track
update Track -> () -> ()
`seq` ()
        Ruler RulerId
ruler_id -> RulerId
ruler_id RulerId -> () -> ()
`seq` ()
        State u
u -> u
u u -> () -> ()
`seq` ()

instance (Pretty t, Pretty u) => Pretty (Update t u) where
    format :: Update t u -> Doc
format = \case
        View ViewId
view_id View
update -> Text -> [Doc] -> Doc
Pretty.constructor Text
"View"
            [ViewId -> Doc
forall a. Pretty a => a -> Doc
Pretty.format ViewId
view_id, View -> Doc
forall a. Pretty a => a -> Doc
Pretty.format View
update]
        Block BlockId
block_id Block t
update -> Text -> [Doc] -> Doc
Pretty.constructor Text
"Block"
            [BlockId -> Doc
forall a. Pretty a => a -> Doc
Pretty.format BlockId
block_id, Block t -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Block t
update]
        Track TrackId
track_id Track
update -> Text -> [Doc] -> Doc
Pretty.constructor Text
"Track"
            [TrackId -> Doc
forall a. Pretty a => a -> Doc
Pretty.format TrackId
track_id, Track -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Track
update]
        Ruler RulerId
ruler_id -> Text -> [Doc] -> Doc
Pretty.constructor Text
"Ruler" [RulerId -> Doc
forall a. Pretty a => a -> Doc
Pretty.format RulerId
ruler_id]
        State u
update -> Text -> [Doc] -> Doc
Pretty.constructor Text
"State" [u -> Doc
forall a. Pretty a => a -> Doc
Pretty.format u
update]

instance Pretty View where
    format :: View -> Doc
format View
update = case View
update of
        View
CreateView -> Doc
"CreateView"
        View
DestroyView -> Doc
"DestroyView"
        ViewSize Rect
rect -> Text -> [Doc] -> Doc
Pretty.constructor Text
"ViewSize" [Rect -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Rect
rect]
        Status Map (Int, Text) Text
status Color
is_root -> Text -> [Doc] -> Doc
Pretty.constructor Text
"Status"
            [Map (Int, Text) Text -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Map (Int, Text) Text
status, Color -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Color
is_root]
        TrackScroll Int
width ->
            Text -> [Doc] -> Doc
Pretty.constructor Text
"TrackScroll" [Int -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Int
width]
        Zoom Zoom
zoom -> Text -> [Doc] -> Doc
Pretty.constructor Text
"Zoom" [Zoom -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Zoom
zoom]
        Selection Int
selnum Maybe Selection
sel -> Text -> [Doc] -> Doc
Pretty.constructor Text
"Selection"
            [Int -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Int
selnum, Maybe Selection -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Maybe Selection
sel]
        View
BringToFront -> Doc
"BringToFront"
        TitleFocus Maybe Int
tracknum ->
            Text -> [Doc] -> Doc
Pretty.constructor Text
"TitleFocus" [Maybe Int -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Maybe Int
tracknum]

instance Pretty t => Pretty (Block t) where
    format :: Block t -> Doc
format Block t
update = case Block t
update of
        BlockTitle Text
s -> Text -> [Doc] -> Doc
Pretty.constructor Text
"BlockTitle"
            [Text -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Text
s]
        BlockConfig Config
config -> Text -> [Doc] -> Doc
Pretty.constructor Text
"BlockConfig"
            [Config -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Config
config]
        BlockSkeleton Skeleton
skel [(Color, [(Int, Int)])]
int_skel -> Text -> [Doc] -> Doc
Pretty.constructor Text
"BlockSkeleton"
            [Skeleton -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Skeleton
skel, [(Color, [(Int, Int)])] -> Doc
forall a. Pretty a => a -> Doc
Pretty.format [(Color, [(Int, Int)])]
int_skel]
        RemoveTrack Int
n -> Text -> [Doc] -> Doc
Pretty.constructor Text
"RemoveTrack"
            [Int -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Int
n]
        InsertTrack Int
n t
t -> Text -> [Doc] -> Doc
Pretty.constructor Text
"InsertTrack"
            [Int -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Int
n, t -> Doc
forall a. Pretty a => a -> Doc
Pretty.format t
t]
        BlockTrack Int
n t
t -> Text -> [Doc] -> Doc
Pretty.constructor Text
"BlockTrack"
            [Int -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Int
n, t -> Doc
forall a. Pretty a => a -> Doc
Pretty.format t
t]

instance Pretty Track where
    format :: Track -> Doc
format Track
update = case Track
update of
        TrackEvents TrackTime
s TrackTime
e -> Text -> [Doc] -> Doc
Pretty.constructor Text
"TrackEvents"
            [TrackTime -> Doc
forall a. Pretty a => a -> Doc
Pretty.format TrackTime
s, TrackTime -> Doc
forall a. Pretty a => a -> Doc
Pretty.format TrackTime
e]
        Track
TrackAllEvents -> Text -> Doc
Pretty.text Text
"TrackAllEvents"
        TrackTitle Text
s -> Text -> [Doc] -> Doc
Pretty.constructor Text
"TrackTitle" [Text -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Text
s]
        TrackBg Color
c -> Text -> [Doc] -> Doc
Pretty.constructor Text
"TrackTitle" [Color -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Color
c]
        TrackRender RenderConfig
config -> Text -> [Doc] -> Doc
Pretty.constructor Text
"TrackTitle"
            [RenderConfig -> Doc
forall a. Pretty a => a -> Doc
Pretty.format RenderConfig
config]

instance Pretty State where
    format :: State -> Doc
format State
update = case State
update of
        Config Config
config -> Text -> [Doc] -> Doc
Pretty.constructor Text
"Config" [Config -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Config
config]
        CreateBlock BlockId
block_id Block
_ -> Text -> [Doc] -> Doc
Pretty.constructor Text
"CreateBlock"
            [BlockId -> Doc
forall a. Pretty a => a -> Doc
Pretty.format BlockId
block_id]
        DestroyBlock BlockId
block_id -> Text -> [Doc] -> Doc
Pretty.constructor Text
"DestroyBlock"
            [BlockId -> Doc
forall a. Pretty a => a -> Doc
Pretty.format BlockId
block_id]
        CreateTrack TrackId
track_id Track
_ -> Text -> [Doc] -> Doc
Pretty.constructor Text
"CreateTrack"
            [TrackId -> Doc
forall a. Pretty a => a -> Doc
Pretty.format TrackId
track_id]
        DestroyTrack TrackId
track_id -> Text -> [Doc] -> Doc
Pretty.constructor Text
"DestroyTrack"
            [TrackId -> Doc
forall a. Pretty a => a -> Doc
Pretty.format TrackId
track_id]
        CreateRuler RulerId
ruler_id Ruler
_ -> Text -> [Doc] -> Doc
Pretty.constructor Text
"CreateRuler"
            [RulerId -> Doc
forall a. Pretty a => a -> Doc
Pretty.format RulerId
ruler_id]
        DestroyRuler RulerId
ruler_id -> Text -> [Doc] -> Doc
Pretty.constructor Text
"DestroyRuler"
            [RulerId -> Doc
forall a. Pretty a => a -> Doc
Pretty.format RulerId
ruler_id]

update_id :: Update t State -> Maybe Id.Id
update_id :: forall t. Update t State -> Maybe Id
update_id = \case
    View ViewId
view_id View
_ -> ViewId -> Maybe Id
forall a. Ident a => a -> Maybe Id
ident ViewId
view_id
    Block BlockId
block_id Block t
_ -> BlockId -> Maybe Id
forall a. Ident a => a -> Maybe Id
ident BlockId
block_id
    Track TrackId
track_id Track
_ -> TrackId -> Maybe Id
forall a. Ident a => a -> Maybe Id
ident TrackId
track_id
    Ruler RulerId
ruler_id -> RulerId -> Maybe Id
forall a. Ident a => a -> Maybe Id
ident RulerId
ruler_id
    State State
st -> case State
st of
        Config {} -> Maybe Id
forall a. Maybe a
Nothing
        CreateBlock BlockId
block_id Block
_ -> BlockId -> Maybe Id
forall a. Ident a => a -> Maybe Id
ident BlockId
block_id
        DestroyBlock BlockId
block_id -> BlockId -> Maybe Id
forall a. Ident a => a -> Maybe Id
ident BlockId
block_id
        CreateTrack TrackId
track_id Track
_ -> TrackId -> Maybe Id
forall a. Ident a => a -> Maybe Id
ident TrackId
track_id
        DestroyTrack TrackId
track_id -> TrackId -> Maybe Id
forall a. Ident a => a -> Maybe Id
ident TrackId
track_id
        CreateRuler RulerId
ruler_id Ruler
_ -> RulerId -> Maybe Id
forall a. Ident a => a -> Maybe Id
ident RulerId
ruler_id
        DestroyRuler RulerId
ruler_id -> RulerId -> Maybe Id
forall a. Ident a => a -> Maybe Id
ident RulerId
ruler_id
    where
    ident :: Id.Ident a => a -> Maybe Id.Id
    ident :: forall a. Ident a => a -> Maybe Id
ident = Id -> Maybe Id
forall a. a -> Maybe a
Just (Id -> Maybe Id) -> (a -> Id) -> a -> Maybe Id
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Id
forall a. Ident a => a -> Id
Id.unpack_id

-- | Convert a UiUpdate to a DisplayUpdate by stripping out all the UiUpdate
-- parts.
to_display :: UiUpdate -> Maybe DisplayUpdate
to_display :: UiUpdate -> Maybe DisplayUpdate
to_display = \case
    View ViewId
vid View
update -> DisplayUpdate -> Maybe DisplayUpdate
forall a. a -> Maybe a
Just (DisplayUpdate -> Maybe DisplayUpdate)
-> DisplayUpdate -> Maybe DisplayUpdate
forall a b. (a -> b) -> a -> b
$ ViewId -> View -> DisplayUpdate
forall t u. ViewId -> View -> Update t u
View ViewId
vid View
update
    Block BlockId
bid Block Track
update -> BlockId -> Block DisplayTrack -> DisplayUpdate
forall t u. BlockId -> Block t -> Update t u
Block BlockId
bid (Block DisplayTrack -> DisplayUpdate)
-> Maybe (Block DisplayTrack) -> Maybe DisplayUpdate
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case Block Track
update of
        BlockTitle Text
a -> Block DisplayTrack -> Maybe (Block DisplayTrack)
forall a. a -> Maybe a
Just (Block DisplayTrack -> Maybe (Block DisplayTrack))
-> Block DisplayTrack -> Maybe (Block DisplayTrack)
forall a b. (a -> b) -> a -> b
$ Text -> Block DisplayTrack
forall t. Text -> Block t
BlockTitle Text
a
        BlockConfig Config
a -> Block DisplayTrack -> Maybe (Block DisplayTrack)
forall a. a -> Maybe a
Just (Block DisplayTrack -> Maybe (Block DisplayTrack))
-> Block DisplayTrack -> Maybe (Block DisplayTrack)
forall a b. (a -> b) -> a -> b
$ Config -> Block DisplayTrack
forall t. Config -> Block t
BlockConfig Config
a
        BlockSkeleton Skeleton
a [(Color, [(Int, Int)])]
b -> Block DisplayTrack -> Maybe (Block DisplayTrack)
forall a. a -> Maybe a
Just (Block DisplayTrack -> Maybe (Block DisplayTrack))
-> Block DisplayTrack -> Maybe (Block DisplayTrack)
forall a b. (a -> b) -> a -> b
$ Skeleton -> [(Color, [(Int, Int)])] -> Block DisplayTrack
forall t. Skeleton -> [(Color, [(Int, Int)])] -> Block t
BlockSkeleton Skeleton
a [(Color, [(Int, Int)])]
b
        RemoveTrack {} -> Maybe (Block DisplayTrack)
forall a. Maybe a
Nothing
        InsertTrack {} -> Maybe (Block DisplayTrack)
forall a. Maybe a
Nothing
        BlockTrack {} -> Maybe (Block DisplayTrack)
forall a. Maybe a
Nothing
    Track TrackId
tid Track
update -> DisplayUpdate -> Maybe DisplayUpdate
forall a. a -> Maybe a
Just (DisplayUpdate -> Maybe DisplayUpdate)
-> DisplayUpdate -> Maybe DisplayUpdate
forall a b. (a -> b) -> a -> b
$ TrackId -> Track -> DisplayUpdate
forall t u. TrackId -> Track -> Update t u
Track TrackId
tid Track
update
    Ruler RulerId
rid -> DisplayUpdate -> Maybe DisplayUpdate
forall a. a -> Maybe a
Just (DisplayUpdate -> Maybe DisplayUpdate)
-> DisplayUpdate -> Maybe DisplayUpdate
forall a b. (a -> b) -> a -> b
$ RulerId -> DisplayUpdate
forall t u. RulerId -> Update t u
Ruler RulerId
rid
    State {} -> Maybe DisplayUpdate
forall a. Maybe a
Nothing

to_ui :: UiDamage -> [UiUpdate]
to_ui :: UiDamage -> [UiUpdate]
to_ui (UiDamage { Map TrackId (Ranges TrackTime)
_tracks :: Map TrackId (Ranges TrackTime)
_tracks :: UiDamage -> Map TrackId (Ranges TrackTime)
_tracks, Set RulerId
_rulers :: Set RulerId
_rulers :: UiDamage -> Set RulerId
_rulers, Set ViewId
_bring_to_front :: Set ViewId
_bring_to_front :: UiDamage -> Set ViewId
_bring_to_front, Maybe (ViewId, Maybe Int)
_title_focus :: Maybe (ViewId, Maybe Int)
_title_focus :: UiDamage -> Maybe (ViewId, Maybe Int)
_title_focus }) = [[UiUpdate]] -> [UiUpdate]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [ TrackId -> Track -> UiUpdate
forall t u. TrackId -> Track -> Update t u
Track TrackId
tid (Track -> UiUpdate) -> Track -> UiUpdate
forall a b. (a -> b) -> a -> b
$ Track
-> ((TrackTime, TrackTime) -> Track)
-> Maybe (TrackTime, TrackTime)
-> Track
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Track
TrackAllEvents ((TrackTime -> TrackTime -> Track)
-> (TrackTime, TrackTime) -> Track
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry TrackTime -> TrackTime -> Track
TrackEvents) Maybe (TrackTime, TrackTime)
mb_range
      | (TrackId
tid, Ranges TrackTime
range) <- Map TrackId (Ranges TrackTime) -> [(TrackId, Ranges TrackTime)]
forall k a. Map k a -> [(k, a)]
Map.toList Map TrackId (Ranges TrackTime)
_tracks
      , Just Maybe (TrackTime, TrackTime)
mb_range <- [Ranges TrackTime -> Maybe (Maybe (TrackTime, TrackTime))
forall n. Ranges n -> Maybe (Maybe (n, n))
Ranges.extract1 Ranges TrackTime
range]
      ]
    , (RulerId -> UiUpdate) -> [RulerId] -> [UiUpdate]
forall a b. (a -> b) -> [a] -> [b]
map RulerId -> UiUpdate
forall t u. RulerId -> Update t u
Ruler (Set RulerId -> [RulerId]
forall a. Set a -> [a]
Set.toList Set RulerId
_rulers)
    , (ViewId -> UiUpdate) -> [ViewId] -> [UiUpdate]
forall a b. (a -> b) -> [a] -> [b]
map ((ViewId -> View -> UiUpdate) -> View -> ViewId -> UiUpdate
forall a b c. (a -> b -> c) -> b -> a -> c
flip ViewId -> View -> UiUpdate
forall t u. ViewId -> View -> Update t u
View View
BringToFront) (Set ViewId -> [ViewId]
forall a. Set a -> [a]
Set.toList Set ViewId
_bring_to_front)
    , [UiUpdate]
-> ((ViewId, Maybe Int) -> [UiUpdate])
-> Maybe (ViewId, Maybe Int)
-> [UiUpdate]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\(ViewId
vid, Maybe Int
tracknum) -> [ViewId -> View -> UiUpdate
forall t u. ViewId -> View -> Update t u
View ViewId
vid (Maybe Int -> View
TitleFocus Maybe Int
tracknum)])
        Maybe (ViewId, Maybe Int)
_title_focus
    ]
    -- views and blocks not converted, but they tell diff where to look.

-- | Reduce a UiUpdate to its corresponding UiDamage.  UiUpdates are more
-- specific, so this is discarding information, which I'll have to recover
-- later via Diff.
--
-- This seems silly, and maybe it is.  It's because I originally used only diff
-- for updates, but then added UiDamage to make diff more efficient.  Perhaps
-- I should move entirely to collecting updates and get rid of diff.  But as
-- long as diff is fairly efficient, when directed to the appropriate places
-- via UiDamage, then it still seems less error prone to do the diff.
to_damage :: UiUpdate -> UiDamage
to_damage :: UiUpdate -> UiDamage
to_damage = \case
    View ViewId
view_id View
view -> case View
view of
        -- I can discard BringToFront and TitleFocus because they're just
        -- instructions to Sync and don't indicate UI damage.
        BringToFront {} -> UiDamage
forall a. Monoid a => a
mempty
        TitleFocus {} -> UiDamage
forall a. Monoid a => a
mempty
        View
_ -> ViewId -> UiDamage
view_damage ViewId
view_id
    Block BlockId
block_id Block Track
_ -> BlockId -> UiDamage
block_damage BlockId
block_id
    Track TrackId
track_id Track
track -> TrackId -> Ranges TrackTime -> UiDamage
track_damage TrackId
track_id (Ranges TrackTime -> UiDamage) -> Ranges TrackTime -> UiDamage
forall a b. (a -> b) -> a -> b
$ case Track
track of
        TrackEvents TrackTime
s TrackTime
e -> TrackTime -> TrackTime -> Ranges TrackTime
forall n. n -> n -> Ranges n
Ranges.range TrackTime
s TrackTime
e
        Track
_ -> Ranges TrackTime
forall n. Ranges n
Ranges.everything
    Ruler RulerId
ruler_id -> RulerId -> UiDamage
ruler_damage RulerId
ruler_id
    State State
state -> case State
state of
        Config {} -> UiDamage
forall a. Monoid a => a
mempty
        CreateBlock BlockId
block_id Block
_ -> BlockId -> UiDamage
block_damage BlockId
block_id
        DestroyBlock BlockId
block_id -> BlockId -> UiDamage
block_damage BlockId
block_id
        CreateTrack TrackId
track_id Track
_ -> TrackId -> Ranges TrackTime -> UiDamage
track_damage TrackId
track_id Ranges TrackTime
forall n. Ranges n
Ranges.everything
        DestroyTrack TrackId
track_id -> TrackId -> Ranges TrackTime -> UiDamage
track_damage TrackId
track_id Ranges TrackTime
forall n. Ranges n
Ranges.everything
        CreateRuler RulerId
ruler_id Ruler
_ -> RulerId -> UiDamage
ruler_damage RulerId
ruler_id
        DestroyRuler RulerId
ruler_id -> RulerId -> UiDamage
ruler_damage RulerId
ruler_id

-- * functions

-- | Updates which purely manipulate the view are not recorded by undo.
is_view_update :: UiUpdate -> Bool
is_view_update :: UiUpdate -> Bool
is_view_update = \case
    View ViewId
_ View
view_update -> case View
view_update of
        CreateView {} -> Bool
False
        View
DestroyView -> Bool
False
        View
_ -> Bool
True
    Block BlockId
_ Block Track
block_update -> case Block Track
block_update of
        BlockConfig Config
_ -> Bool
True
        Block Track
_ -> Bool
False
    Track TrackId
_ Track
track_update -> case Track
track_update of
        TrackBg {} -> Bool
True
        TrackRender {} -> Bool
True
        Track
_ -> Bool
False
    UiUpdate
_ -> Bool
False

-- | Score damage is used by Diff.score_changed to determine if a change has
-- happened which is worthy of saving to disk, or recording for undo.
is_score_damage :: UiDamage -> Bool
is_score_damage :: UiDamage -> Bool
is_score_damage (UiDamage { Map TrackId (Ranges TrackTime)
_tracks :: Map TrackId (Ranges TrackTime)
_tracks :: UiDamage -> Map TrackId (Ranges TrackTime)
_tracks, Set RulerId
_rulers :: Set RulerId
_rulers :: UiDamage -> Set RulerId
_rulers, Bool
_score_damage :: Bool
_score_damage :: UiDamage -> Bool
_score_damage }) =
    -- This doesn't check _blocks, because those happen on any block change at
    -- all, which includes UI-only things like Block.config_skel_box.
    Bool
_score_damage Bool -> Bool -> Bool
|| Bool -> Bool
not (Map TrackId (Ranges TrackTime) -> Bool
forall k a. Map k a -> Bool
Map.null Map TrackId (Ranges TrackTime)
_tracks) Bool -> Bool -> Bool
|| Bool -> Bool
not (Set RulerId -> Bool
forall a. Set a -> Bool
Set.null Set RulerId
_rulers)

-- | Does an update imply a change which would require rederiving?
track_changed :: UiUpdate -> Maybe (TrackId, Ranges.Ranges ScoreTime)
track_changed :: UiUpdate -> Maybe (TrackId, Ranges TrackTime)
track_changed (Track TrackId
tid Track
update) = case Track
update of
    TrackEvents TrackTime
start TrackTime
end -> (TrackId, Ranges TrackTime) -> Maybe (TrackId, Ranges TrackTime)
forall a. a -> Maybe a
Just (TrackId
tid, TrackTime -> TrackTime -> Ranges TrackTime
forall n. n -> n -> Ranges n
Ranges.range TrackTime
start TrackTime
end)
    Track
TrackAllEvents -> (TrackId, Ranges TrackTime) -> Maybe (TrackId, Ranges TrackTime)
forall a. a -> Maybe a
Just (TrackId
tid, Ranges TrackTime
forall n. Ranges n
Ranges.everything)
    TrackTitle Text
_ -> (TrackId, Ranges TrackTime) -> Maybe (TrackId, Ranges TrackTime)
forall a. a -> Maybe a
Just (TrackId
tid, Ranges TrackTime
forall n. Ranges n
Ranges.everything)
    Track
_ -> Maybe (TrackId, Ranges TrackTime)
forall a. Maybe a
Nothing
track_changed UiUpdate
_ = Maybe (TrackId, Ranges TrackTime)
forall a. Maybe a
Nothing

-- | Some Updates have to happen before others.
sort :: [DisplayUpdate] -> [DisplayUpdate]
sort :: [DisplayUpdate] -> [DisplayUpdate]
sort = (DisplayUpdate -> Int) -> [DisplayUpdate] -> [DisplayUpdate]
forall k a. Ord k => (a -> k) -> [a] -> [a]
Seq.sort_on DisplayUpdate -> Int
sort_key

sort_key :: DisplayUpdate -> Int
sort_key :: DisplayUpdate -> Int
sort_key = \case
    -- Other updates may refer to the created view.
    View ViewId
_ (CreateView {}) -> Int
0
    -- No sense syncing updates to a view that's going to go away, so destroy
    -- it right away.
    View ViewId
_ View
DestroyView -> Int
0
    -- These may change the meaning of TrackNums.  Update TrackNums refer to
    -- the TrackNums of the destination state, except the ones for InsertTrack
    -- and RemoveTrack, of course.
    Block BlockId
_ (InsertTrack {}) -> Int
1
    Block BlockId
_ (RemoveTrack {}) -> Int
1
    -- Make sure to focus after creating it.
    View ViewId
_ (TitleFocus {}) -> Int
10
    DisplayUpdate
_ -> Int
2