-- 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 NamedFieldPuns #-}
-- | Functions for larger scale transformations on a State.
module Ui.Transform where
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Text as Text

import qualified Util.Logger as Logger
import qualified Util.Maps as Maps
import qualified Util.Memory as Memory
import qualified Util.Num as Num

import qualified Derive.ShowVal as ShowVal
import qualified Ui.Block as Block
import qualified Ui.Event as Event
import qualified Ui.Events as Events
import qualified Ui.Id as Id
import qualified Ui.Track as Track
import qualified Ui.Ui as Ui
import qualified Ui.UiConfig as UiConfig

import           Global
import           Types


-- | Transform TracklikeIds.
tracks :: Ui.M m => BlockId -> (Block.TracklikeId -> Block.TracklikeId) -> m ()
tracks :: forall (m :: * -> *).
M m =>
BlockId -> (TracklikeId -> TracklikeId) -> m ()
tracks BlockId
block_id TracklikeId -> TracklikeId
f = do
    Block
block <- Block -> Block
modify forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => BlockId -> m Block
Ui.get_block BlockId
block_id
    forall (m :: * -> *). M m => (State -> State) -> m ()
Ui.modify forall a b. (a -> b) -> a -> b
$ \State
st -> State
st
        { state_blocks :: Map BlockId Block
Ui.state_blocks = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert BlockId
block_id Block
block (State -> Map BlockId Block
Ui.state_blocks State
st) }
    where
    modify :: Block -> Block
modify Block
block = Block
block
        { block_tracks :: [Track]
Block.block_tracks = forall a b. (a -> b) -> [a] -> [b]
map Track -> Track
modify_track (Block -> [Track]
Block.block_tracks Block
block) }
    modify_track :: Track -> Track
modify_track Track
t = Track
t { tracklike_id :: TracklikeId
Block.tracklike_id = TracklikeId -> TracklikeId
f (Track -> TracklikeId
Block.tracklike_id Track
t) }

-- * map IDs

-- | Map a function across the IDs in the given state.  Any collisions are
-- thrown in Left.
map_state_ids :: (Id.Id -> Id.Id) -> Ui.State -> Either Ui.Error Ui.State
map_state_ids :: (Id -> Id) -> State -> Either Error State
map_state_ids Id -> Id
f State
state = forall a. State -> StateId a -> Either Error State
Ui.exec State
state (forall (m :: * -> *). M m => (Id -> Id) -> m ()
map_ids Id -> Id
f)

-- | Transform IDs, but don't update view_id pointer map.  So only use this
-- when you are sure there are no visible views (\"invisible\" views occur
-- after they are created but before the sync).  This should probably only be
-- used by 'map_state_ids'.
map_ids :: Ui.M m => (Id.Id -> Id.Id) -> m ()
map_ids :: forall (m :: * -> *). M m => (Id -> Id) -> m ()
map_ids Id -> Id
f = do
    forall (m :: * -> *). M m => (Id -> Id) -> m ()
map_view_ids Id -> Id
f
    forall (m :: * -> *). M m => (Id -> Id) -> m ()
map_block_ids Id -> Id
f
    forall (m :: * -> *). M m => (Id -> Id) -> m ()
map_track_ids Id -> Id
f
    forall (m :: * -> *). M m => (Id -> Id) -> m ()
map_ruler_ids Id -> Id
f

map_namespace :: Ui.M m => (Id.Namespace -> Id.Namespace) -> m ()
map_namespace :: forall (m :: * -> *). M m => (Namespace -> Namespace) -> m ()
map_namespace Namespace -> Namespace
modify = forall (m :: * -> *). M m => (Id -> Id) -> m ()
map_ids Id -> Id
set
    where set :: Id -> Id
set Id
ident = Namespace -> Id -> Id
Id.set_namespace (Namespace -> Namespace
modify (Id -> Namespace
Id.id_namespace Id
ident)) Id
ident

map_view_ids :: Ui.M m => (Id.Id -> Id.Id) -> m ()
map_view_ids :: forall (m :: * -> *). M m => (Id -> Id) -> m ()
map_view_ids Id -> Id
f = do
    Map ViewId View
views <- forall (m :: * -> *) a. M m => (State -> a) -> m a
Ui.gets State -> Map ViewId View
Ui.state_views
    Map ViewId View
new_views <- forall (m :: * -> *) k v.
(M m, Ord k, Show k) =>
String -> (k -> k) -> Map k v -> m (Map k v)
safe_map_keys String
"state_views" (forall a. Ident a => (Id -> Id) -> a -> a
Id.modify Id -> Id
f) Map ViewId View
views
    forall (m :: * -> *). M m => (State -> State) -> m ()
Ui.modify forall a b. (a -> b) -> a -> b
$ \State
st -> State
st { state_views :: Map ViewId View
Ui.state_views = Map ViewId View
new_views }

-- | Rename a BlockId.  Views are updated to point to the new block.
map_block_ids :: Ui.M m => (Id.Id -> Id.Id) -> m ()
map_block_ids :: forall (m :: * -> *). M m => (Id -> Id) -> m ()
map_block_ids Id -> Id
f = do
    Maybe BlockId
maybe_root <- forall (m :: * -> *). M m => m (Maybe BlockId)
Ui.lookup_root_id
    let new_root :: Maybe BlockId
new_root = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Id -> BlockId
Id.BlockId forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Id
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ident a => a -> Id
Id.unpack_id) Maybe BlockId
maybe_root
    Map BlockId Block
blocks <- forall (m :: * -> *) a. M m => (State -> a) -> m a
Ui.gets State -> Map BlockId Block
Ui.state_blocks
    Map BlockId Block
new_blocks <- forall (m :: * -> *) k v.
(M m, Ord k, Show k) =>
String -> (k -> k) -> Map k v -> m (Map k v)
safe_map_keys String
"state_blocks" BlockId -> BlockId
modify Map BlockId Block
blocks
    Map ViewId View
views <- forall (m :: * -> *) a. M m => (State -> a) -> m a
Ui.gets State -> Map ViewId View
Ui.state_views
    let new_views :: Map ViewId View
new_views = forall a b k. (a -> b) -> Map k a -> Map k b
Map.map
            (\View
v -> View
v { view_block :: BlockId
Block.view_block = BlockId -> BlockId
modify forall a b. (a -> b) -> a -> b
$ View -> BlockId
Block.view_block View
v })
            Map ViewId View
views
    forall (m :: * -> *). M m => (State -> State) -> m ()
Ui.modify forall a b. (a -> b) -> a -> b
$ \State
st -> State
st
        { state_blocks :: Map BlockId Block
Ui.state_blocks = Block -> Block
map_block forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map BlockId Block
new_blocks
        , state_views :: Map ViewId View
Ui.state_views = Map ViewId View
new_views
        }
    forall (m :: * -> *). M m => (Config -> Config) -> m ()
Ui.modify_config forall a b. (a -> b) -> a -> b
$ \Config
config -> Config
config { config_root :: Maybe BlockId
UiConfig.config_root = Maybe BlockId
new_root }
    where
    map_block :: Block -> Block
map_block Block
b = Block
b
        { block_integrated :: Maybe (BlockId, TrackDestinations)
Block.block_integrated =
            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first BlockId -> BlockId
modify) (Block -> Maybe (BlockId, TrackDestinations)
Block.block_integrated Block
b)
        }
    modify :: BlockId -> BlockId
modify = forall a. Ident a => (Id -> Id) -> a -> a
Id.modify Id -> Id
f

map_track_ids :: Ui.M m => (Id.Id -> Id.Id) -> m ()
map_track_ids :: forall (m :: * -> *). M m => (Id -> Id) -> m ()
map_track_ids Id -> Id
f = do
    Map TrackId Track
tracks <- forall (m :: * -> *) a. M m => (State -> a) -> m a
Ui.gets State -> Map TrackId Track
Ui.state_tracks
    Map TrackId Track
new_tracks <- forall (m :: * -> *) k v.
(M m, Ord k, Show k) =>
String -> (k -> k) -> Map k v -> m (Map k v)
safe_map_keys String
"state_tracks" TrackId -> TrackId
modify Map TrackId Track
tracks
    Map BlockId Block
blocks <- forall (m :: * -> *) a. M m => (State -> a) -> m a
Ui.gets State -> Map BlockId Block
Ui.state_blocks
    let new_blocks :: Map BlockId Block
new_blocks = forall a b k. (a -> b) -> Map k a -> Map k b
Map.map Block -> Block
map_block Map BlockId Block
blocks
    forall (m :: * -> *). M m => (State -> State) -> m ()
Ui.modify forall a b. (a -> b) -> a -> b
$ \State
st -> State
st
        { state_tracks :: Map TrackId Track
Ui.state_tracks = Map TrackId Track
new_tracks, state_blocks :: Map BlockId Block
Ui.state_blocks = Map BlockId Block
new_blocks }
    where
    map_block :: Block -> Block
map_block Block
b = Block
b
        { block_tracks :: [Track]
Block.block_tracks =
            forall a b. (a -> b) -> [a] -> [b]
map ((TrackId -> TrackId) -> Track -> Track
map_track TrackId -> TrackId
modify) (Block -> [Track]
Block.block_tracks Block
b)
        , block_integrated :: Maybe (BlockId, TrackDestinations)
Block.block_integrated =
            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TrackDestinations -> TrackDestinations
map_track_dests) (Block -> Maybe (BlockId, TrackDestinations)
Block.block_integrated Block
b)
        , block_integrated_tracks :: [(TrackId, TrackDestinations)]
Block.block_integrated_tracks =
            forall a b. (a -> b) -> [a] -> [b]
map (\(TrackId
tid, TrackDestinations
dests) -> (TrackId -> TrackId
modify TrackId
tid, TrackDestinations -> TrackDestinations
map_track_dests TrackDestinations
dests))
                (Block -> [(TrackId, TrackDestinations)]
Block.block_integrated_tracks Block
b)
        , block_integrated_manual :: ManualDestinations
Block.block_integrated_manual =
            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NoteDestination -> NoteDestination
map_note_dest) (Block -> ManualDestinations
Block.block_integrated_manual Block
b)
        }
    -- This is getting complicated with integrate.  A generic map like uniplate
    -- would be able to do this automatically.
    map_track :: (TrackId -> TrackId) -> Track -> Track
map_track TrackId -> TrackId
f = (TrackId -> TrackId) -> Track -> Track
map_merged TrackId -> TrackId
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TrackId -> TrackId) -> Track -> Track
map_track_id TrackId -> TrackId
f
    map_track_id :: (TrackId -> TrackId) -> Track -> Track
map_track_id TrackId -> TrackId
f Track
track = case Track -> TracklikeId
Block.tracklike_id Track
track of
        Block.TId TrackId
tid RulerId
rid ->
            (TracklikeId -> TracklikeId) -> Track -> Track
Block.modify_id (forall a b. a -> b -> a
const (TrackId -> RulerId -> TracklikeId
Block.TId (TrackId -> TrackId
f TrackId
tid) RulerId
rid)) Track
track
        TracklikeId
_ -> Track
track
    map_merged :: (TrackId -> TrackId) -> Track -> Track
map_merged TrackId -> TrackId
f Track
track = Track
track
        { track_merged :: Set TrackId
Block.track_merged = forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map TrackId -> TrackId
f (Track -> Set TrackId
Block.track_merged Track
track) }
    map_track_dests :: TrackDestinations -> TrackDestinations
map_track_dests = \case
        Block.DeriveDestinations [NoteDestination]
dests ->
            [NoteDestination] -> TrackDestinations
Block.DeriveDestinations forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map NoteDestination -> NoteDestination
map_note_dest [NoteDestination]
dests
        Block.ScoreDestinations ScoreDestinations
dests ->
            ScoreDestinations -> TrackDestinations
Block.ScoreDestinations forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap TrackId -> TrackId
modify (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first TrackId -> TrackId
modify)) ScoreDestinations
dests
    map_note_dest :: NoteDestination -> NoteDestination
map_note_dest (Block.NoteDestination Text
key (TrackId, EventIndex)
note Map Text (TrackId, EventIndex)
controls) =
        Block.NoteDestination
            { dest_key :: Text
dest_key = Text
key
            , dest_note :: (TrackId, EventIndex)
dest_note = forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first TrackId -> TrackId
modify (TrackId, EventIndex)
note
            , dest_controls :: Map Text (TrackId, EventIndex)
dest_controls = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first TrackId -> TrackId
modify) Map Text (TrackId, EventIndex)
controls
            }
    modify :: TrackId -> TrackId
modify = forall a. Ident a => (Id -> Id) -> a -> a
Id.modify Id -> Id
f

map_ruler_ids :: Ui.M m => (Id.Id -> Id.Id) -> m ()
map_ruler_ids :: forall (m :: * -> *). M m => (Id -> Id) -> m ()
map_ruler_ids Id -> Id
f = do
    Map RulerId Ruler
rulers <- forall (m :: * -> *) a. M m => (State -> a) -> m a
Ui.gets State -> Map RulerId Ruler
Ui.state_rulers
    Map RulerId Ruler
new_rulers <- forall (m :: * -> *) k v.
(M m, Ord k, Show k) =>
String -> (k -> k) -> Map k v -> m (Map k v)
safe_map_keys String
"state_rulers" (forall a. Ident a => (Id -> Id) -> a -> a
Id.modify Id -> Id
f) Map RulerId Ruler
rulers

    Map BlockId Block
blocks <- forall (m :: * -> *) a. M m => (State -> a) -> m a
Ui.gets State -> Map BlockId Block
Ui.state_blocks
    let new_blocks :: Map BlockId Block
new_blocks = forall a b k. (a -> b) -> Map k a -> Map k b
Map.map
            (\Block
b -> Block
b { block_tracks :: [Track]
Block.block_tracks =
                forall a b. (a -> b) -> [a] -> [b]
map ((RulerId -> RulerId) -> Track -> Track
map_track (forall a. Ident a => (Id -> Id) -> a -> a
Id.modify Id -> Id
f)) (Block -> [Track]
Block.block_tracks Block
b) })
            Map BlockId Block
blocks
    forall (m :: * -> *). M m => (State -> State) -> m ()
Ui.modify forall a b. (a -> b) -> a -> b
$ \State
st ->
        State
st { state_rulers :: Map RulerId Ruler
Ui.state_rulers = Map RulerId Ruler
new_rulers, state_blocks :: Map BlockId Block
Ui.state_blocks = Map BlockId Block
new_blocks }
    where
    map_track :: (RulerId -> RulerId) -> Track -> Track
map_track RulerId -> RulerId
f Track
track = case Track -> TracklikeId
Block.tracklike_id Track
track of
        Block.TId TrackId
tid RulerId
rid ->
            (TracklikeId -> TracklikeId) -> Track -> Track
Block.modify_id (forall a b. a -> b -> a
const (TrackId -> RulerId -> TracklikeId
Block.TId TrackId
tid (RulerId -> RulerId
f RulerId
rid))) Track
track
        Block.RId RulerId
rid -> (TracklikeId -> TracklikeId) -> Track -> Track
Block.modify_id (forall a b. a -> b -> a
const (RulerId -> TracklikeId
Block.RId (RulerId -> RulerId
f RulerId
rid))) Track
track
        TracklikeId
_ -> Track
track

safe_map_keys :: (Ui.M m, Ord k, Show k) =>
    String -> (k -> k) -> Map k v -> m (Map k v)
safe_map_keys :: forall (m :: * -> *) k v.
(M m, Ord k, Show k) =>
String -> (k -> k) -> Map k v -> m (Map k v)
safe_map_keys String
name k -> k
f Map k v
fm0
    | forall k a. Map k a -> Int
Map.size Map k v
fm1 forall a. Eq a => a -> a -> Bool
== forall k a. Map k a -> Int
Map.size Map k v
fm0 = forall (m :: * -> *) a. Monad m => a -> m a
return Map k v
fm1
    | Bool
otherwise = forall (m :: * -> *) a. (Stack, M m) => Text -> m a
Ui.throw forall a b. (a -> b) -> a -> b
$ Text
"keys collided in " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt String
name forall a. Semigroup a => a -> a -> a
<> Text
": "
        forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt (forall k a. Map k a -> [k]
Map.keys (forall k a b. Ord k => Map k a -> Map k b -> Map k a
Map.difference Map k v
fm0 Map k v
fm1))
    where fm1 :: Map k v
fm1 = forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeys k -> k
f Map k v
fm0

-- * namespace

-- | Destroy all views, blocks, tracks, and rulers with the given namespace.
destroy_namespace :: Ui.M m => Id.Namespace -> m ()
destroy_namespace :: forall (m :: * -> *). M m => Namespace -> m ()
destroy_namespace Namespace
ns = do
    -- Will destroy any views too.
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *). M m => BlockId -> m ()
Ui.destroy_block forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a. M m => (State -> a) -> m a
Ui.gets (forall a. Ident a => [a] -> [a]
in_ns forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [k]
Map.keys forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Map BlockId Block
Ui.state_blocks)
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *). M m => TrackId -> m ()
Ui.destroy_track forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a. M m => (State -> a) -> m a
Ui.gets (forall a. Ident a => [a] -> [a]
in_ns forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [k]
Map.keys forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Map TrackId Track
Ui.state_tracks)
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *). M m => RulerId -> m ()
Ui.destroy_ruler forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a. M m => (State -> a) -> m a
Ui.gets (forall a. Ident a => [a] -> [a]
in_ns forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [k]
Map.keys forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Map RulerId Ruler
Ui.state_rulers)
    where
    in_ns :: Id.Ident a => [a] -> [a]
    in_ns :: forall a. Ident a => [a] -> [a]
in_ns = forall a. (a -> Bool) -> [a] -> [a]
filter forall a b. (a -> b) -> a -> b
$ (forall a. Eq a => a -> a -> Bool
==Namespace
ns) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ident a => a -> Namespace
Id.ident_namespace

-- | Replace the namespace of the second state with the one from the first
-- state.
replace_namespace :: Id.Namespace -> Ui.State -> Ui.State -> Ui.State
replace_namespace :: Namespace -> State -> State -> State
replace_namespace Namespace
ns State
from State
to = State
to
    { state_views :: Map ViewId View
Ui.state_views = forall {a} {a}. (Ord a, Ident a) => (State -> Map a a) -> Map a a
merge State -> Map ViewId View
Ui.state_views
    , state_blocks :: Map BlockId Block
Ui.state_blocks = forall {a} {a}. (Ord a, Ident a) => (State -> Map a a) -> Map a a
merge State -> Map BlockId Block
Ui.state_blocks
    , state_tracks :: Map TrackId Track
Ui.state_tracks = forall {a} {a}. (Ord a, Ident a) => (State -> Map a a) -> Map a a
merge State -> Map TrackId Track
Ui.state_tracks
    , state_rulers :: Map RulerId Ruler
Ui.state_rulers = forall {a} {a}. (Ord a, Ident a) => (State -> Map a a) -> Map a a
merge State -> Map RulerId Ruler
Ui.state_rulers
    }
    where
    merge :: (State -> Map a a) -> Map a a
merge State -> Map a a
field =
        forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union (forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey (\a
k a
_ -> a -> Bool
wanted a
k) (State -> Map a a
field State
from)) (State -> Map a a
field State
to)
        where wanted :: a -> Bool
wanted = (forall a. Eq a => a -> a -> Bool
==Namespace
ns) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ident a => a -> Namespace
Id.ident_namespace

-- * code

type UpdateM a = Logger.Logger Text a

-- | Modify tracklang code: block titles, track titles, events.
map_code :: (Text -> Text) -> Ui.State -> (Ui.State, [Text])
map_code :: (Text -> Text) -> State -> (State, [Text])
map_code Text -> Text
modify State
state = forall w a. Logger w a -> (a, [w])
Logger.runId forall a b. (a -> b) -> a -> b
$ do
    [(TrackId, Track)]
tracks <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(TrackId
tid, Track
track) -> (TrackId
tid,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {m :: * -> *} {a}.
(MonadLogger Text m, Pretty a) =>
a -> Track -> m Track
u_track TrackId
tid Track
track)
        (forall k a. Map k a -> [(k, a)]
Map.toList (State -> Map TrackId Track
Ui.state_tracks State
state))
    [(BlockId, Block)]
blocks <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(BlockId
bid, Block
block) -> (BlockId
bid,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {m :: * -> *} {a}.
(MonadLogger Text m, Pretty a) =>
a -> Block -> m Block
u_block BlockId
bid Block
block)
        (forall k a. Map k a -> [(k, a)]
Map.toList (State -> Map BlockId Block
Ui.state_blocks State
state))
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ State
state
        { state_tracks :: Map TrackId Track
Ui.state_tracks = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(TrackId, Track)]
tracks
        , state_blocks :: Map BlockId Block
Ui.state_blocks = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(BlockId, Block)]
blocks
        }
    where
    u_track :: a -> Track -> m Track
u_track a
track_id Track
track = do
        let old :: Text
old = Track -> Text
Track.track_title Track
track
        let new :: Text
new = Text -> Text
modify Text
old
        forall {a} {m :: * -> *}.
(Eq a, MonadLogger Text m, ShowVal a) =>
Text -> a -> a -> m ()
log (forall a. Pretty a => a -> Text
pretty a
track_id) Text
old Text
new
        Events
events <- [Event] -> Events
Events.from_list forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {m :: * -> *}. MonadLogger Text m => Event -> m Event
u_event (Events -> [Event]
Events.ascending (Track -> Events
Track.track_events Track
track))
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Track
track { track_title :: Text
Track.track_title = Text
new, track_events :: Events
Track.track_events = Events
events }
    u_event :: Event -> m Event
u_event Event
event = do
        let old :: Text
old = Event -> Text
Event.text Event
event
        let new :: Text
new = Text -> Text
modify Text
old
        forall {a} {m :: * -> *}.
(Eq a, MonadLogger Text m, ShowVal a) =>
Text -> a -> a -> m ()
log (forall a. Pretty a => a -> Text
pretty (Event -> TrackTime
Event.start Event
event)) Text
old Text
new
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text -> Event -> Event
Event.set_text_raw Text
new Event
event
    u_block :: a -> Block -> m Block
u_block a
block_id Block
block = do
        let old :: Text
old = Block -> Text
Block.block_title Block
block
        let new :: Text
new = Text -> Text
modify Text
old
        forall {a} {m :: * -> *}.
(Eq a, MonadLogger Text m, ShowVal a) =>
Text -> a -> a -> m ()
log (forall a. Pretty a => a -> Text
pretty a
block_id) Text
old Text
new
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Block
block { block_title :: Text
Block.block_title = Text
new }
    log :: Text -> a -> a -> m ()
log Text
place a
old a
new
        | a
new forall a. Eq a => a -> a -> Bool
/= a
old = forall w (m :: * -> *). MonadLogger w m => w -> m ()
Logger.log forall a b. (a -> b) -> a -> b
$ Text
place forall a. Semigroup a => a -> a -> a
<> Text
": "
            forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Text
ShowVal.show_val a
old forall a. Semigroup a => a -> a -> a
<> Text
" -> " forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Text
ShowVal.show_val a
new
        | Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- * merge

-- | Merge ID maps from the states together.  Collisions will throw.
-- The 'Ui.Config' comes from the first state.
merge_states :: Ui.State -> Ui.State -> Either Ui.Error Ui.State
merge_states :: State -> State -> Either Error State
merge_states State
st0 State
st1 = forall a. State -> StateId a -> Either Error State
Ui.exec State
st0 forall a b. (a -> b) -> a -> b
$ do
    Map ViewId View
views <- forall (m :: * -> *) k a.
(M m, Ord k, Show k) =>
String -> Map k a -> Map k a -> m (Map k a)
safe_union String
"views" (State -> Map ViewId View
Ui.state_views State
st0) (State -> Map ViewId View
Ui.state_views State
st1)
    Map BlockId Block
blocks <- forall (m :: * -> *) k a.
(M m, Ord k, Show k) =>
String -> Map k a -> Map k a -> m (Map k a)
safe_union String
"blocks" (State -> Map BlockId Block
Ui.state_blocks State
st0) (State -> Map BlockId Block
Ui.state_blocks State
st1)
    Map TrackId Track
tracks <- forall (m :: * -> *) k a.
(M m, Ord k, Show k) =>
String -> Map k a -> Map k a -> m (Map k a)
safe_union String
"tracks" (State -> Map TrackId Track
Ui.state_tracks State
st0) (State -> Map TrackId Track
Ui.state_tracks State
st1)
    Map RulerId Ruler
rulers <- forall (m :: * -> *) k a.
(M m, Ord k, Show k) =>
String -> Map k a -> Map k a -> m (Map k a)
safe_union String
"rulers" (State -> Map RulerId Ruler
Ui.state_rulers State
st0) (State -> Map RulerId Ruler
Ui.state_rulers State
st1)
    forall (m :: * -> *). M m => (State -> State) -> m ()
Ui.modify forall a b. (a -> b) -> a -> b
$ \State
st -> State
st
        { state_views :: Map ViewId View
Ui.state_views = Map ViewId View
views, state_blocks :: Map BlockId Block
Ui.state_blocks = Map BlockId Block
blocks
        , state_tracks :: Map TrackId Track
Ui.state_tracks = Map TrackId Track
tracks, state_rulers :: Map RulerId Ruler
Ui.state_rulers = Map RulerId Ruler
rulers
        }

safe_union :: (Ui.M m, Ord k, Show k) => String
    -> Map k a -> Map k a -> m (Map k a)
safe_union :: forall (m :: * -> *) k a.
(M m, Ord k, Show k) =>
String -> Map k a -> Map k a -> m (Map k a)
safe_union String
name Map k a
fm0 Map k a
fm1
    | forall k a. Map k a -> Bool
Map.null Map k a
overlapping = forall (m :: * -> *) a. Monad m => a -> m a
return Map k a
fm
    | Bool
otherwise = forall (m :: * -> *) a. (Stack, M m) => Text -> m a
Ui.throw forall a b. (a -> b) -> a -> b
$ Text
"keys collided in " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt String
name forall a. Semigroup a => a -> a -> a
<> Text
": "
        forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt (forall k a. Map k a -> [k]
Map.keys Map k a
overlapping)
    where (Map k a
fm, Map k a
overlapping) = forall k a. Ord k => Map k a -> Map k a -> (Map k a, Map k a)
Maps.uniqueUnion Map k a
fm0 Map k a
fm1


-- * intern

-- | Increase sharing in event text with an intern table.
intern_text :: Ui.State -> (Ui.State, Map Text Int)
intern_text :: State -> (State, Map Text Int)
intern_text State
state =
    (State
state { state_tracks :: Map TrackId Track
Ui.state_tracks = forall k a. Eq k => [(k, a)] -> Map k a
Map.fromAscList [(TrackId, Track)]
tracks }, forall a b k. (a -> b) -> Map k a -> Map k b
Map.map forall a b. (a, b) -> b
snd Map Text (Text, Int)
table)
    where
    (Map Text (Text, Int)
table, [(TrackId, Track)]
tracks) = forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
List.mapAccumL forall {a}.
Map Text (Text, Int)
-> (a, Track) -> (Map Text (Text, Int), (a, Track))
intern_track forall k a. Map k a
Map.empty
        (forall k a. Map k a -> [(k, a)]
Map.toAscList (State -> Map TrackId Track
Ui.state_tracks State
state))
    intern_track :: Map Text (Text, Int)
-> (a, Track) -> (Map Text (Text, Int), (a, Track))
intern_track Map Text (Text, Int)
state (a
track_id, Track
track) =
        ( Map Text (Text, Int)
state2, (a
track_id
        , Track
track { track_events :: Events
Track.track_events = [Event] -> Events
Events.from_list [Event]
events })
        )
        where
        (Map Text (Text, Int)
state2, [Event]
events) = forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
List.mapAccumL Map Text (Text, Int) -> Event -> (Map Text (Text, Int), Event)
Event.intern_event Map Text (Text, Int)
state
            (Events -> [Event]
Events.ascending (Track -> Events
Track.track_events Track
track))

intern_stats :: Map Text Int -> (Memory.Size, Int)
intern_stats :: Map Text Int -> (Size, Int)
intern_stats Map Text Int
table =
    (forall a. Integral a => a -> Size
Memory.fromBytes forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
Num.sum (forall a b. (a -> b) -> [a] -> [b]
map (Text, Int) -> Int
stats (forall k a. Map k a -> [(k, a)]
Map.toList Map Text Int
table)), Int
total_hits)
    where
    total_hits :: Int
total_hits = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
Num.sum (forall k a. Map k a -> [a]
Map.elems Map Text Int
table) forall a. Num a => a -> a -> a
- forall k a. Map k a -> Int
Map.size Map Text Int
table
    stats :: (Text, Int) -> Int
stats (Text
text, Int
hits) = Int
size forall a. Num a => a -> a -> a
* (Int
hits forall a. Num a => a -> a -> a
- Int
1)
        where size :: Int
size = Text -> Int
Text.length Text
text forall a. Num a => a -> a -> a
* Int
2 forall a. Num a => a -> a -> a
+ Int
3 forall a. Num a => a -> a -> a
* Int
4 -- pointer + length + start

-- * stats

data Stats = Stats {
    Stats -> Int
_blocks :: Int
    , Stats -> Int
_tracks :: Int
    , Stats -> Int
_events :: Int
    } deriving (Int -> Stats -> ShowS
[Stats] -> ShowS
Stats -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Stats] -> ShowS
$cshowList :: [Stats] -> ShowS
show :: Stats -> String
$cshow :: Stats -> String
showsPrec :: Int -> Stats -> ShowS
$cshowsPrec :: Int -> Stats -> ShowS
Show)

short_stats :: Ui.State -> Text
short_stats :: State -> Text
short_stats State
state = [Text] -> Text
Text.unwords
    [ Text
"blocks:" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Int
_blocks
    , Text
"tracks:" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Int
_tracks
    , Text
"events:" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Int
_events
    ]
    where Stats { Int
_blocks :: Int
_blocks :: Stats -> Int
_blocks, Int
_tracks :: Int
_tracks :: Stats -> Int
_tracks, Int
_events :: Int
_events :: Stats -> Int
_events } = State -> Stats
stats State
state

show_stats :: Ui.State -> Text
show_stats :: State -> Text
show_stats State
state = [Text] -> Text
Text.unlines
    [ Text
"blocks: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Int
_blocks
    , Text
"tracks: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Int
_tracks
        forall a. Semigroup a => a -> a -> a
<> Text
" (" forall a. Semigroup a => a -> a -> a
<> forall a. RealFloat a => Int -> a -> Text
Num.showFloat Int
2 Double
per_block forall a. Semigroup a => a -> a -> a
<>  Text
" per block)"
    , Text
"events: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Int
_events
        forall a. Semigroup a => a -> a -> a
<> Text
" (" forall a. Semigroup a => a -> a -> a
<> forall a. RealFloat a => Int -> a -> Text
Num.showFloat Int
2 Double
per_event forall a. Semigroup a => a -> a -> a
<> Text
" per track)"
    ]
    where
    per_block :: Double
per_block = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
_tracks forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
_blocks
    per_event :: Double
per_event = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
_events forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
_tracks
    Stats { Int
_blocks :: Int
_blocks :: Stats -> Int
_blocks, Int
_tracks :: Int
_tracks :: Stats -> Int
_tracks, Int
_events :: Int
_events :: Stats -> Int
_events } = State -> Stats
stats State
state

stats :: Ui.State -> Stats
stats :: State -> Stats
stats State
state = Stats
    { _blocks :: Int
_blocks = forall k a. Map k a -> Int
Map.size (State -> Map BlockId Block
Ui.state_blocks State
state)
    , _tracks :: Int
_tracks = forall k a. Map k a -> Int
Map.size (State -> Map TrackId Track
Ui.state_tracks State
state)
    , _events :: Int
_events = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
Num.sum forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Events -> Int
Events.length forall b c a. (b -> c) -> (a -> b) -> a -> c
. Track -> Events
Track.track_events) forall a b. (a -> b) -> a -> b
$
        forall k a. Map k a -> [a]
Map.elems forall a b. (a -> b) -> a -> b
$ State -> Map TrackId Track
Ui.state_tracks State
state
    }