-- 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{- | The overall UI state is described here. This is an immutable data
structure that contains all the tracks, rulers, note data, and so forth.
It exports a StateT monad for modification and access.
Since the same block may have \>=0 views, and a single track may appear in
\>=0 blocks, these are stored as IDs rather than directly in their
containers. Using explicit references introduces all the usual problems
with pointers like invalid references and unreferenced data. The latter is
actually a feature (e.g. having a block with no associated view is
perfectly normal), but the former is a pain. To ease the pain, IDs should
only be created via the monadic create_* interface in this module, even
though I'm forced to export their constructors to avoid circular imports.
There may still be problems with IDs from one State being applied to
a different State (likely an older and newer version of the same State),
but I'll deal with that when I get there.
A higher level interface (e.g. "Cmd.Create") may ease this by automatically
creating objects with automatically generated IDs.
-}moduleUi.Ui(State(..),views,blocks,tracks,rulers,config,empty,create,clear-- * config,Config(..),empty_config,SavedViews,namespace_,meta,root,allocations,allocations_map,lilypond,default_,saved_views,ky,Meta(..),empty_meta,creation,last_save,notes,midi_performances,lilypond_performances,Performance(..),MidiPerformance,LilypondPerformance,Default(..),empty_default,tempo-- * address types,Track(..),Range(..),TrackInfo(..)-- * StateT monad,M,StateT,StateId,get,unsafe_put,update,get_updates,throw_error,throw,run,run_id,eval,eval_rethrow,exec,exec_rethrow,gets,unsafe_modify,put,modify-- ** errors,Error(..),require,require_right-- * config,get_namespace,set_namespace,get_default,modify_default,get_root_id,lookup_root_id,set_root_id,modify_config,get_config,with_config,modify_allocation,allocation-- * view,get_view,lookup_view,all_view_ids,create_view,destroy_view,put_views,set_view_status-- ** zoom and track scroll,get_zoom,modify_zoom,set_track_scroll,set_view_rect,set_view_padding-- ** selections,get_selection,set_selection,shift_selection,skip_unselectable_tracks,selectable_tracks-- * block,get_block,lookup_block,all_block_ids,all_block_track_ids,create_config_block,create_block,destroy_block,block_of,block_id_of,views_of,get_block_title,set_block_title,modify_block_meta,set_integrated_block,modify_integrated_tracks,set_integrated_manual,set_block_config,set_edit_box,set_play_box,block_ruler_end,block_event_end,block_end,block_logical_range-- ** skeleton,get_skeleton,set_skeleton,modify_skeleton,toggle_skeleton_edge,add_edges,remove_edges,splice_skeleton_above,splice_skeleton_below-- ** tracks,insert_track,remove_track,move_track-- *** tracks by tracknum,track_count,block_track_at,get_block_track_at,track_at,event_track_at,get_event_track_at,ruler_track_at,block_ruler-- *** tracks by TrackId,track_ids_of,tracknums_of,tracknum_of,get_tracknum_of-- *** block track,set_track_width,track_flags,track_collapsed,toggle_track_flag,add_track_flag,remove_track_flag,modify_track_flags,set_track_ruler,merge_track,unmerge_track,set_merged_tracks,track_merged,set_ruler_ids,replace_ruler_id,get_tracklike-- * track,get_track,lookup_track,all_track_ids,create_track,destroy_track,get_track_title,set_track_title,modify_track_title,set_track_bg,modify_track_render,set_render_style,blocks_with_track_id-- ** events,insert_events,insert_block_events,insert_event,get_events,modify_events,modify_events_range,modify_events_from,modify_some_events,calculate_damage,remove_event,remove_events,remove_events_range,track_event_end,range_from-- * ruler,get_ruler,lookup_ruler,all_ruler_ids,create_ruler,destroy_ruler,modify_ruler,ruler_of,rulers_of,blocks_with_ruler_id,no_ruler-- * util,find_tracks-- * verify,quick_verify,verify-- TODO should be done automatically by put-- * ID,read_id,namespace)whereimportqualifiedControl.ApplicativeasApplicativeimportqualifiedControl.DeepSeqasDeepSeqimportqualifiedControl.Monad.ExceptasExceptimportqualifiedControl.Monad.IdentityasIdentityimportqualifiedControl.Monad.StateasStateimportqualifiedControl.Monad.TransasTransimportqualifiedData.ListasListimportqualifiedData.MapasMapimportqualifiedData.MaybeasMaybeimportqualifiedData.SetasSetimportqualifiedData.TextasTextimportqualifiedData.TimeasTimeimportqualifiedGHC.StackimportqualifiedUtil.CallStackasCallStackimportqualifiedUtil.LensasLensimportqualifiedUtil.LoggerasLoggerimportqualifiedUtil.PrettyasPrettyimportqualifiedUtil.RangesasRangesimportqualifiedUtil.RectasRectimportqualifiedUtil.SeqasSeqimportqualifiedUi.BlockasBlockimportqualifiedUi.ColorasColorimportqualifiedUi.EventasEventimportqualifiedUi.EventsasEventsimportqualifiedUi.IdasIdimportqualifiedUi.RulerasRulerimportqualifiedUi.SelasSelimportqualifiedUi.SkeletonasSkeletonimportqualifiedUi.TrackasTrackimportqualifiedUi.TypesasTypesimportqualifiedUi.UiConfigasUiConfigimportUi.UiConfighiding(allocation,modify_allocation)importqualifiedUi.UpdateasUpdateimportqualifiedUi.ZoomasZoomimportqualifiedDerive.ScoreTypesasScoreTypesimportqualifiedDerive.StackasStackimportqualifiedApp.ConfigasConfigimportGlobalimportTypes-- * types-- | Score state. When you save a score, this is what is saved to disk.dataState=State{state_views::MapViewIdBlock.View,state_blocks::MapBlockIdBlock.Block,state_tracks::MapTrackIdTrack.Track,state_rulers::MapRulerIdRuler.Ruler,state_config::Config}deriving(Eq,Show)views::Lens.LensState(MapViewIdBlock.View)views=Lens.lensstate_views(\fr->r{state_views=f(state_viewsr)})blocks::Lens.LensState(MapBlockIdBlock.Block)blocks=Lens.lensstate_blocks(\fr->r{state_blocks=f(state_blocksr)})tracks::Lens.LensState(MapTrackIdTrack.Track)tracks=Lens.lensstate_tracks(\fr->r{state_tracks=f(state_tracksr)})rulers::Lens.LensState(MapRulerIdRuler.Ruler)rulers=Lens.lensstate_rulers(\fr->r{state_rulers=f(state_rulersr)})config::Lens.LensStateConfigconfig=Lens.lensstate_config(\fr->r{state_config=f(state_configr)})empty::Stateempty=State{state_views=Map.empty,state_blocks=Map.empty,state_tracks=Map.empty,state_rulers=Map.empty,state_config=empty_config}-- | Like 'empty', but the state is initialized with the current creation time.create::IOStatecreate=donow<-Time.getCurrentTimereturn$(config#meta#creation#=now)empty-- | Clear out data that shouldn't be saved.clear::State->Stateclearstate=state{state_views=Map.mapclear_view(state_viewsstate)}whereclear_viewview=view{Block.view_status=mempty,Block.view_selections=-- Non-insert selections indicate ephemeral state.maybemempty(Map.singletonConfig.insert_selnum)$Map.lookupConfig.insert_selnum(Block.view_selectionsview)}instancePrettyStatewhereformat(Stateviewsblockstracksrulersconfig)=Pretty.record"State"[("views",Pretty.formatviews),("blocks",Pretty.formatblocks),("tracks",Pretty.formattracks),("rulers",Pretty.formatrulers),("config",Pretty.formatconfig)]instanceDeepSeq.NFDataStatewherernf(Stateviewsblockstracksrulersconfig)=DeepSeq.rnfviews`seq`DeepSeq.rnfblocks`seq`DeepSeq.rnftracks`seq`DeepSeq.rnfrulers`seq`config`seq`()-- * address types-- | Address a track in a block. This is similar to a TrackId, except it-- doesn't guarantee that the track is an event track.dataTrack=Track!BlockId!TrackNumderiving(Eq,Show)instancePrettyTrackwherepretty(Trackblock_idtracknum)=prettyblock_id<>"/"<>showttracknum-- | A position on a track that can be indicated on the UI. Its Pretty-- instance emits a string, which if logged or copy-pasted into the REPL, will-- cause that section of score to be highlighted.dataRange=Range!(MaybeBlockId)!TrackId!TrackTime!TrackTimederiving(Eq,Show)instancePrettyRangewherepretty(Rangemaybe_block_idtrack_idstartend)=Stack.log_ui_frame(maybe_block_id,Justtrack_id,Just(start,end))-- * other types-- | Summary information on a Track.dataTrackInfo=TrackInfo{track_title::!Text,track_id::!TrackId,track_tracknum::!TrackNum,track_block::!Block.Track}deriving(Eq,Show)instancePrettyTrackInfowherepretty(TrackInfotitletrack_idtracknum_)="("<>Text.unwords["TrackInfo",showttitle,showttrack_id,showttracknum]<>")"-- * StateT monad-- | TrackUpdates are stored directly instead of being calculated from the-- state diff.---- Is there any way they could get out of sync with the actual change? I don't-- see how, since the updates are stored by track_id, which should always be-- associated with the same track, and an operation to move event positions-- will simply generate another TrackUpdate over the whole track. This does-- mean TrackUpdates can overlap, so 'Ui.Sync.sync' should collapse them.typeStateStackm=State.StateTState(Logger.LoggerTUpdate.CmdUpdate(Except.ExceptTErrorm))newtypeStateTma=StateT(StateStackma)deriving(Functor,Monad,Trans.MonadIO,Except.MonadErrorError,Applicative.Applicative)-- | Just a convenient abbreviation.typeStateIda=StateTIdentity.IdentityainstanceTrans.MonadTransStateTwherelift=StateT.lift.lift.lift-- | Monads implementing this class can call the UI state functions directly.class(Applicative.Applicativem,Monadm)=>Mmwhere-- Note that these aren't the MonadState get and put, and can't be, because-- when this monad is layered under another state monad (as it is with-- Cmd), MonadState couldn't tell which one you wanted.get::mState-- | This directly modifies the state, and can break internal invariants.-- 'put' is slower but safer since it checks those invariants.unsafe_put::State->m()update::Update.CmdUpdate->m()get_updates::m[Update.CmdUpdate]throw_error::Error->mainstanceMonadm=>M(StateTm)whereget=StateTState.getunsafe_putst=StateT(State.putst)updateupd=(StateT.lift)(Logger.logupd)get_updates=(StateT.lift)Logger.peekthrow_error=StateT.lift.lift.Except.throwErrorthrow::(CallStack.Stack,Mm)=>Text->mathrowmsg=throw_error$ErrorCallStack.callStackmsggets::Mm=>(State->a)->magetsf=fmapfget-- | As with 'unsafe_put', this directly modifies the state. 'modify' is-- the safe version.unsafe_modify::Mm=>(State->State)->m()unsafe_modifyf=dostate<-getunsafe_put$!fstate-- | TODO verify---- This updates all tracks because I don't know what you modified in there.put::Mm=>State->m()putstate=unsafe_putstate>>update_all_tracks-- | An arbitrary modify. It's unsafe because it doesn't check internal-- invariants, and inefficient because it damages all tracks. Use more-- specific modify_* functions, if possible.modify::Mm=>(State->State)->m()modifyf=dostate<-getput$!fstate-- | Run the given StateT with the given initial state, and return a new-- state along with updates. Normally updates are produced by 'Ui.Diff.diff',-- but for efficiency updates to track data are accumulated when they are-- actually made. All the UI needs is a TrackTime range to redraw in, and-- redrawing the whole track isn't that expensive.---- See the StateStack comment for more.run::Monadm=>State->StateTma->m(EitherError(a,State,[Update.CmdUpdate]))runstatem=dores<-(Except.runExceptT.Logger.run.flipState.runStateTstate.(\(StateTx)->x))mreturn$caseresofLefterr->LefterrRight((val,state),updates)->Right(val,state,updates)run_id::State->StateIda->EitherError(a,State,[Update.CmdUpdate])run_idstatem=Identity.runIdentity(runstatem)-- | A form of 'run' that returns only the val and automatically runs in-- Identity.eval::State->StateIda->EitherErroraevalstatem=caseresultofLefterr->LefterrRight(val,_,_)->Rightvalwhereresult=Identity.runIdentity(runstatem)eval_rethrow::Mm=>Text->State->StateIda->maeval_rethrowmsgstate=require_right(((msg<>": ")<>).pretty).evalstateexec::State->StateIda->EitherErrorStateexecstatem=caseresultofLefterr->LefterrRight(_,state',_)->Rightstate'whereresult=Identity.runIdentity(runstatem)exec_rethrow::Mm=>Text->State->StateIda->mStateexec_rethrowmsgstate=require_right(((msg<>": ")<>).pretty).execstate-- ** error-- | Abort is used by Cmd, so don't throw it from here. This isn't exactly-- modular, but ErrorT can't be composed and extensible exceptions are too-- much bother at the moment.dataError=Error!GHC.Stack.CallStack!Text|Abortderiving(Show)instancePrettyErrorwherepretty(Errorstackmsg)=CallStack.showCaller(CallStack.callerstack)<>" "<>msgprettyAbort="(abort)"require::(CallStack.Stack,Mm)=>Text->Maybea->marequireerr=maybe(throwerr)returnrequire_right::(CallStack.Stack,Mm)=>(err->Text)->Eithererra->marequire_rightfmt_err=either(throw.fmt_err)return-- * configget_namespace::Mm=>mId.Namespaceget_namespace=get_configconfig_namespaceset_namespace::Mm=>Id.Namespace->m()set_namespacens=modify_config$\st->st{config_namespace=ns}get_default::Mm=>(Default->a)->maget_defaultf=f<$>get_configconfig_defaultmodify_default::Mm=>(Default->Default)->m()modify_defaultf=modify_config$\st->st{config_default=f(config_defaultst)}get_root_id::Mm=>mBlockIdget_root_id=require"no root root_id"=<<lookup_root_idlookup_root_id::Mm=>m(MaybeBlockId)lookup_root_id=get_configconfig_rootset_root_id::Mm=>BlockId->m()set_root_idblock_id=modify_config$\st->st{config_root=Justblock_id}-- | Unlike other State fields, you can modify Config freely without worrying-- about breaking invariants. TODO except allocations have invariants.modify_config::Mm=>(Config->Config)->m()modify_configf=unsafe_modify$\st->st{state_config=f(state_configst)}modify_allocation::Mm=>ScoreTypes.Instrument->(Allocation->Allocation)->m()modify_allocationinstmodify=doallocs<-config#allocations<#>getallocs<-require_right(("modify "<>prettyinst<>": ")<>)$UiConfig.modify_allocationinst(Right.modify)allocsmodify_config$allocations#=allocsget_config::Mm=>(Config->a)->maget_configf=gets(f.state_config)-- | Run the action with a modified state, and restore it.with_config::Mm=>(Config->Config)->ma->mawith_configfaction=doold<-get_configidmodify_configf-- I think this is exception safe because the state is reverted after an-- exception, and there's no way to catch an exception.result<-actionmodify_config$constoldreturnresult-- | TODO use this for read only. If used for write it bypasses-- 'UiConfig.allocate'.allocation::ScoreTypes.Instrument->LensState(MaybeAllocation)allocationinst=config#allocations_map#Lens.mapinst-- * viewget_view::Mm=>ViewId->mBlock.Viewget_viewview_id=get>>=lookup_idview_id.state_viewslookup_view::Mm=>ViewId->m(MaybeBlock.View)lookup_viewview_id=gets(Map.lookupview_id.state_views)-- | All ViewIds, in sorted order.all_view_ids::Mm=>m[ViewId]all_view_ids=gets(Map.keys.state_views)-- | Create a new view. Block.view_tracks can be left empty, since it will-- be replaced by views generated from the the block. If the caller uses the-- 'Block.view' constructor, it won't have to worry about this.---- Throw if the ViewId already exists.create_view::Mm=>Id.Id->Block.View->mViewIdcreate_viewidview=doview<-_update_view_statusviewinsert(Id.ViewIdid)viewstate_views$\viewsst->st{state_views=views}destroy_view::Mm=>ViewId->m()destroy_viewview_id=unsafe_modify$\st->st{state_views=Map.deleteview_id(state_viewsst)}put_views::Mm=>MapViewIdBlock.View->m()put_viewsview_map=dolet(view_ids,views)=unzip(Map.toListview_map)views<-mapM_update_view_statusviewsunsafe_modify$\st->st{state_views=Map.fromList(zipview_idsviews)}-- | Set a status variable on a view.set_view_status::Mm=>ViewId->(Int,Text)->MaybeText->m()set_view_statusview_idkeyval=modify_viewview_id$\view->view{Block.view_status=Map.alter(constval)key(Block.view_statusview)}_update_view_status::Mm=>Block.View->mBlock.View_update_view_statusview=doblock<-get_block(Block.view_blockview)return$caseBlock.block_integratedblockofJust(source_block,_)->view{Block.view_status=Map.insertConfig.status_integrate_source(Id.ident_textsource_block)(Block.view_statusview)}Nothing->view-- ** zoom and track scrollget_zoom::Mm=>ViewId->mZoom.Zoomget_zoom=fmapBlock.view_zoom.get_viewmodify_zoom::Mm=>ViewId->(Zoom.Zoom->Zoom.Zoom)->m()modify_zoomview_idmodify=modify_viewview_id$\view->view{Block.view_zoom=clamp$modify$Block.view_zoomview}whereclampzoom=zoom{Zoom.offset=max0(Zoom.offsetzoom)}set_track_scroll::Mm=>ViewId->Types.Width->m()set_track_scrollview_idoffset=modify_viewview_id(\view->view{Block.view_track_scroll=offset})set_view_rect::Mm=>ViewId->Rect.Rect->m()set_view_rectview_idrect=modify_viewview_id(\view->view{Block.view_rect=rect})-- | Only 'Cmd.Cmd.ui_update' is supposed to call this, because the UI is-- responsible for the padding.set_view_padding::Mm=>ViewId->Block.Padding->m()set_view_paddingview_idpadding=modify_viewview_id$\view->view{Block.view_padding=padding}-- ** selections-- | Get @view_id@'s selection at @selnum@, or Nothing if there is none.get_selection::Mm=>ViewId->Sel.Num->m(MaybeSel.Selection)get_selectionview_idselnum=doview<-get_viewview_idreturn(Map.lookupselnum(Block.view_selectionsview))-- | Replace any selection on @view_id@ at @selnum@ with @sel@.set_selection::Mm=>ViewId->Sel.Num->MaybeSel.Selection->m()set_selectionview_idselnummaybe_sel=doview<-get_viewview_idupdate_viewview_id$view{Block.view_selections=maybe(Map.deleteselnum)(Map.insertselnum)maybe_sel(Block.view_selectionsview)}-- ** utilupdate_viewview_idview=unsafe_modify$\st->st{state_views=Map.adjust(constview)view_id(state_viewsst)}modify_viewview_idf=doview<-get_viewview_idupdate_viewview_id(fview)-- * blockget_block::Mm=>BlockId->mBlock.Blockget_blockblock_id=get>>=lookup_idblock_id.state_blockslookup_block::Mm=>BlockId->m(MaybeBlock.Block)lookup_blockblock_id=get>>=return.Map.lookupblock_id.state_blocksall_block_ids::Mm=>m[BlockId]all_block_ids=gets(Map.keys.state_blocks)-- | Get all blocks along with their tracks.all_block_track_ids::Mm=>m[(BlockId,[TrackId])]all_block_track_ids=map(secondBlock.block_track_ids)<$>gets(Map.toList.state_blocks)-- | Make a new block. If it's the first one, it will be set as the root.-- This is the low level version, you probably want to use 'create_block'.---- Throw if the BlockId already exists.create_config_block::Mm=>Id.Id->Block.Block->mBlockIdcreate_config_blockidblock=insert(Id.BlockIdid)blockstate_blocks$\blocksst->st{state_blocks=blocks,state_config=letc=state_configstinc{config_root=ifMap.sizeblocks==1thenJust(Id.BlockIdid)elseconfig_rootc}}-- | Make a new block with the default 'Block.Config'.create_block::Mm=>Id.Id->Text->[Block.Track]->mBlockIdcreate_blockblock_idtitletracks=create_config_blockblock_id(Block.blockBlock.default_configtitletracks)-- | Destroy the block and all the views that display it. If the block was-- the root, it will be be unset. The block's tracks are left intact.destroy_block::Mm=>BlockId->m()destroy_blockblock_id=doviews<-views_ofblock_idmapM_destroy_view(Map.keysviews)unsafe_modify$\st->st{state_blocks=Map.deleteblock_id(state_blocksst),state_config=letc=state_configstinc{config_root=ifconfig_rootc==Justblock_idthenNothingelseconfig_rootc}}block_of::Mm=>ViewId->mBlock.Blockblock_ofview_id=get_block.Block.view_block=<<get_viewview_idblock_id_of::Mm=>ViewId->mBlockIdblock_id_ofview_id=Block.view_block<$>get_viewview_id-- | Get all views of a given block.views_of::Mm=>BlockId->m(MapViewIdBlock.View)views_ofblock_id=doviews<-getsstate_viewsreturn$Map.filter((==block_id).Block.view_block)viewsget_block_title::Mm=>BlockId->mTextget_block_title=fmapBlock.block_title.get_blockset_block_title::Mm=>BlockId->Text->m()set_block_titleblock_idtitle=modify_blockblock_id(\block->block{Block.block_title=title})modify_block_meta::Mm=>BlockId->(Block.Meta->Block.Meta)->m()modify_block_metablock_idf=modify_blockblock_id$\block->block{Block.block_meta=f(Block.block_metablock)}set_integrated_block::Mm=>BlockId->Maybe(BlockId,Block.TrackDestinations)->m()set_integrated_blockblock_idintegrated=domodify_blockblock_id$\block->block{Block.block_integrated=integrated}block<-get_blockblock_idvalidate"set_integrated_block"(fix_integrated_blockblock_idblock)modify_integrated_tracks::Mm=>BlockId->([(TrackId,Block.TrackDestinations)]->[(TrackId,Block.TrackDestinations)])->m()modify_integrated_tracksblock_idmodify=domodify_blockblock_id$\block->block{Block.block_integrated_tracks=modify(Block.block_integrated_tracksblock)}block<-get_blockblock_idvalidate"modify_integrated_tracks"(fix_integrated_tracksblock_idblock)set_integrated_manual::Mm=>BlockId->Block.SourceKey->Maybe[Block.NoteDestination]->m()set_integrated_manualblock_idkeydests=domodify_blockblock_id$\block->block{Block.block_integrated_manual=maybe(Map.deletekey)(Map.insertkey)dests(Block.block_integrated_manualblock)}-- TODO validate?set_block_config::Mm=>BlockId->Block.Config->m()set_block_configblock_idconfig=modify_blockblock_id(\block->block{Block.block_config=config})set_edit_box::Mm=>BlockId->Block.Box->Block.Box->m()set_edit_boxblock_idskeltrack=doblock<-get_blockblock_idset_block_configblock_id$(Block.block_configblock){Block.config_skel_box=skel,Block.config_track_box=track}-- | The play box doesn't use a char, so I leave that out.set_play_box::Mm=>BlockId->Color.Color->m()set_play_boxblock_idcolor=doblock<-get_blockblock_idset_block_configblock_id$(Block.block_configblock){Block.config_sb_box=Block.Boxcolor' '}-- | Get the end of the block according to the ruler. This means that if the-- block has no rulers (e.g. a clipboard block) then block_ruler_end will be 0.block_ruler_end::Mm=>BlockId->mTrackTimeblock_ruler_endblock_id=doblock<-get_blockblock_idcaseBlock.block_ruler_idsblockof[]->return0ruler_id:_->Ruler.time_end<$>get_rulerruler_id-- | Get the end of the block according to the last event of the block.block_event_end::Mm=>BlockId->mTrackTimeblock_event_endblock_id=doblock<-get_blockblock_idtrack_ends<-mapMtrack_event_end(Block.block_track_idsblock)return$maximum(0:track_ends)-- | Get the maximum of ruler end and event end. The end may still be 0 if the-- block is totally empty.block_end::Mm=>BlockId->mTrackTimeblock_endblock_id=max<$>block_ruler_endblock_id<*>block_event_endblock_id-- | The logical range is defined by 'Ruler.bounds_of' and is intended to-- correspond to the \"note\" that this block defines.block_logical_range::Mm=>BlockId->m(TrackTime,TrackTime)block_logical_rangeblock_id=doblock<-get_blockblock_idcaseBlock.block_ruler_idsblockof[]->(,)0<$>block_event_endblock_idruler_id:_->do(start,end)<-Ruler.bounds_of<$>get_rulerruler_idend<-maybe(block_event_endblock_id)returnendreturn(start,end)-- ** skeletonget_skeleton::Mm=>BlockId->mSkeleton.Skeletonget_skeletonblock_id=Block.block_skeleton<$>get_blockblock_idset_skeleton::Mm=>BlockId->Skeleton.Skeleton->m()set_skeletonblock_idskel=modify_skeletonblock_id(constskel)modify_skeleton::Mm=>BlockId->(Skeleton.Skeleton->Skeleton.Skeleton)->m()modify_skeletonblock_idf=doblock<-get_blockblock_idletskel=f(Block.block_skeletonblock)tracks=length$Block.block_tracksblockforM_(Skeleton.flattenskel)$\(parent,child)->unless(1<=parent&&parent<tracks&&1<=child&&child<tracks)$throw$"modify_skeleton: edge "<>showt(parent,child)<>" out of range for "<>showtblock_idmodify_blockblock_id$\block->block{Block.block_skeleton=skel}-- | Toggle the given edge in the block's skeleton. If a cycle would be-- created, refuse to add the edge and return False. The edge is in (parent,-- child) order.toggle_skeleton_edge::Mm=>Bool-- ^ If not true, the child's existing parents will be unlinked.-- While a track with multiple parents is possible, and is a way to-- express the same score derived under different conditions, in practice-- I never do that.->BlockId->Skeleton.Edge->mBooltoggle_skeleton_edgeallow_multiple_parentsblock_idedge@(_,child)=doblock<-get_blockblock_idwhenJust(edges_in_rangeblockedge)(throw.("toggle: "<>))letskel=drop_parents(Block.block_skeletonblock)caseSkeleton.toggle_edgeedgeskelofNothing->returnFalseJustnew_skel->doset_blockblock_id$block{Block.block_skeleton=new_skel}returnTruewheredrop_parentsskel|allow_multiple_parents||Skeleton.has_edgeskeledge=skel|otherwise=Skeleton.remove_edgesparentsskelwhereparents=map(,child)(Skeleton.parentsskelchild)-- | Add the edges to the skeleton. Throw if they would produce a cycle.add_edges::Mm=>BlockId->[Skeleton.Edge]->m()add_edgesblock_idedges=doskel<-get_skeletonblock_idblock<-get_blockblock_idwhenJust(msum(map(edges_in_rangeblock)edges))(throw.("add_edges: "<>))maybe(throw$"add_edges "<>showtedges<>" to "<>showtskel<>" would have caused a cycle")(set_skeletonblock_id)(Skeleton.add_edgesedgesskel)remove_edges::Mm=>BlockId->[Skeleton.Edge]->m()remove_edgesblock_idedges=modify_skeletonblock_id(Skeleton.remove_edgesedges)-- | The first tracknum is spliced above the second.splice_skeleton_above::Mm=>BlockId->TrackNum->TrackNum->m()splice_skeleton_above=_splice_skeletonTrue-- | The first tracknum is spliced below the second.splice_skeleton_below::Mm=>BlockId->TrackNum->TrackNum->m()splice_skeleton_below=_splice_skeletonFalse-- | Splice the given tracknum into the skeleton, either above or below-- the @to@ tracknum. What this means exactly is documented in-- 'Util.Graph.splice_above' and 'Util.Graph.slice_below'._splice_skeleton::Mm=>Bool->BlockId->TrackNum->TrackNum->m()_splice_skeletonaboveblock_idnewto=doblock<-get_blockblock_idwhenJust(msum(map(edge_in_rangeblock)[new,to]))(throw.("splice: "<>))letsplice=ifabovethenSkeleton.splice_aboveelseSkeleton.splice_belowmaybe(throw$"splice_skeleton: "<>showt(new,to)<>" would have caused a cycle")(set_skeletonblock_id)(splicenewto(Block.block_skeletonblock))edge_in_range::Block.Block->TrackNum->MaybeTextedge_in_rangeblocktracknum=caseSeq.at(Block.block_tracksblock)tracknumofNothing->Just$"tracknum out of range: "<>showttracknumJustt->caseBlock.tracklike_idtofBlock.TId{}->Nothing_->Just$"edge points to non-event track: "<>showttedges_in_range::Block.Block->Skeleton.Edge->MaybeTextedges_in_rangeblock(from,to)=edge_in_rangeblockfrom<|>edge_in_rangeblockto-- ** tracks-- | Insert a track at the given TrackNum. The TrackNum can be out of range to-- insert a track at the beginning or append it to the end.---- This will throw if it's an event track and the block already contains that-- TrackId. This invariant ensures that a (BlockId, TrackNum) is-- interchangeable with a TrackId.insert_track::Mm=>BlockId->TrackNum->Block.Track->m()insert_trackblock_idtracknumtrack=doblock<-get_blockblock_idviews<-views_ofblock_idwhenJust(Block.track_idtrack)$\track_id->dotrack_ids<-track_ids_ofblock_idwhen(track_id`elem`track_ids)$throw$"insert_track: block "<>showtblock_id<>" already contains "<>showttrack_id-- You can only put a ruler in tracknum 0.unless(tracknum>0||is_rulertrack)$throw$"non-ruler track can't go at tracknum "<>showttracknum<>": "<>prettytracklettracks=Seq.insert_attracknumtrack(Block.block_tracksblock)-- Make sure the views are up to date.views'=Map.map(insert_into_viewblocktracknum)viewsset_blockblock_id$block{Block.block_tracks=tracks,Block.block_skeleton=Skeleton.inserttracknum(Block.block_skeletonblock)}unsafe_modify$\st->st{state_views=Map.unionviews'(state_viewsst)}whereis_rulert=caseBlock.tracklike_idtofBlock.RId{}->True_->False-- | Remove the track at the given tracknum.remove_track::Mm=>BlockId->TrackNum->m()remove_trackblock_idtracknum=doblock<-get_blockblock_idlettracks=Block.block_tracksblockunless(1<=tracknum&&tracknum<lengthtracks)$throw$"remove_track "<>showtblock_id<>" "<>showttracknum<>" out of range 1--"<>showt(lengthtracks)views<-Map.map(remove_from_viewblocktracknum)<$>views_ofblock_idset_blockblock_id$block{Block.block_tracks=Seq.remove_attracknumtracks,Block.block_skeleton=Skeleton.removetracknum(Block.block_skeletonblock)}unsafe_modify$\st->st{state_views=Map.unionviews(state_viewsst)}-- | Move a track from one tracknum to another.move_track::Mm=>BlockId->TrackNum->TrackNum->m()move_trackblock_idfromto=doblock<-get_blockblock_idletmsg="move_track: from "<>showtfrom<>" to "<>showtto<>" out of range"modify_blockblock_id.const=<<requiremsg(move_block_trackfromtoblock)move_block_track::TrackNum->TrackNum->Block.Block->MaybeBlock.Blockmove_block_trackfromtoblock=do-- Things get generally messed up if you try to move an event track to the-- ruler spot.guard(from/=0&&to/=0)tracks<-Seq.movefromto(Block.block_tracksblock)letskel=Skeleton.movefromto(Block.block_skeletonblock)return$block{Block.block_tracks=tracks,Block.block_skeleton=skel}-- *** tracks by TrackNum-- | Number of tracks in the block. This includes the ruler, so subtract 1 if-- you want all non-ruler tracks.track_count::Mm=>BlockId->mTrackNumtrack_countblock_id=doblock<-get_blockblock_idreturn$length(Block.block_tracksblock)-- | Get the Track at @tracknum@, or Nothing if its out of range.block_track_at::Mm=>BlockId->TrackNum->m(MaybeBlock.Track)block_track_atblock_idtracknum|tracknum<0=throw$"block_track_at: negative tracknum: "<>showttracknum|otherwise=doblock<-get_blockblock_idreturn$Seq.at(Block.block_tracksblock)tracknumget_block_track_at::Mm=>BlockId->TrackNum->mBlock.Trackget_block_track_atblock_idtracknum=tracknum_in_rangeblock_idtracknum=<<block_track_atblock_idtracknumwheretracknum_in_rangeblock_idtracknumNothing=docount<-track_countblock_idthrow$"track "<>pretty(Trackblock_idtracknum)<>" out of range 0--"<>showtcounttracknum_in_range__(Justa)=returnatrack_at::Mm=>BlockId->TrackNum->m(MaybeBlock.TracklikeId)track_atblock_idtracknum=domaybe_track<-block_track_atblock_idtracknumreturn$fmapBlock.tracklike_idmaybe_track-- | Like 'track_at', but only for event tracks.event_track_at::Mm=>BlockId->TrackNum->m(MaybeTrackId)event_track_atblock_idtracknum=domaybe_track<-track_atblock_idtracknumreturn$Block.track_id_of=<<maybe_track-- | Like 'event_track_at' but throws if it's not there or not an event track.get_event_track_at::Mm=>BlockId->TrackNum->mTrackIdget_event_track_atblock_idtracknum=dotrack<-get_block_track_atblock_idtracknumrequire("track "<>pretty(Trackblock_idtracknum)<>" not an event track")$Block.track_idtrack-- | Get the RulerId of an event or ruler track, or Nothing if the tracknum is-- out of range or doesn't have a ruler.ruler_track_at::Mm=>BlockId->TrackNum->m(MaybeRulerId)ruler_track_atblock_idtracknum=domaybe_track<-track_atblock_idtracknumreturn$Block.ruler_id_of=<<maybe_track-- | 0 is the conventional ruler tracknum.block_ruler::Mm=>BlockId->mRulerIdblock_rulerblock_id=fromMaybeno_ruler<$>ruler_track_atblock_id0-- *** tracks by TrackId-- | Get all TrackIds of the given block.track_ids_of::Mm=>BlockId->m[TrackId]track_ids_ofblock_id=Block.block_track_ids<$>get_blockblock_id-- | Get all TrackIds of the given block, along with their tracknums.tracknums_of::Mm=>BlockId->m[(TrackId,TrackNum)]tracknums_ofblock_id=extract<$>get_blockblock_idwhereextract=justs.flipzip[0..].mapBlock.track_id.Block.block_tracksjustspairs=[(track_id,tracknum)|(Justtrack_id,tracknum)<-pairs]-- | There can only be one TrackId per block, which allows TrackNums and-- TrackIds to be interchangeable. This is enforced by 'insert_track'.---- The inverse is 'event_track_at'.tracknum_of::Mm=>BlockId->TrackId->m(MaybeTrackNum)tracknum_ofblock_idtid=lookuptid<$>tracknums_ofblock_idget_tracknum_of::Mm=>BlockId->TrackId->mTrackNumget_tracknum_ofblock_idtid=require("tracknum_of: track "<>showttid<>" not in "<>showtblock_id)=<<tracknum_ofblock_idtid-- *** block trackset_track_width::Mm=>BlockId->TrackNum->Types.Width->m()set_track_widthblock_idtracknumwidth=modify_block_trackblock_idtracknum$\btrack->btrack{Block.track_width=width}track_flags::Mm=>BlockId->TrackNum->m(SetBlock.TrackFlag)track_flagsblock_idtracknum=Block.track_flags<$>get_block_track_atblock_idtracknumtrack_collapsed::Mm=>BlockId->TrackNum->mBooltrack_collapsedblock_idtracknum=Block.track_collapsed<$>get_block_track_atblock_idtracknumtoggle_track_flag::Mm=>BlockId->TrackNum->Block.TrackFlag->m()toggle_track_flagblock_idtracknumflag=modify_track_flagsblock_idtracknumtogglewheretoggleflags|flag`Set.member`flags=Set.deleteflagflags|otherwise=Set.insertflagflagsadd_track_flag,remove_track_flag::Mm=>BlockId->TrackNum->Block.TrackFlag->m()add_track_flagblock_idtracknumflag=modify_track_flagsblock_idtracknum(Set.insertflag)remove_track_flagblock_idtracknumflag=modify_track_flagsblock_idtracknum(Set.deleteflag)modify_track_flags::Mm=>BlockId->TrackNum->(SetBlock.TrackFlag->SetBlock.TrackFlag)->m()modify_track_flagsblock_idtracknumf=modify_block_trackblock_idtracknum$\btrack->btrack{Block.track_flags=f(Block.track_flagsbtrack)}set_track_ruler::Mm=>BlockId->TrackNum->RulerId->m()set_track_rulerblock_idtracknumruler_id=do_<-get_rulerruler_id-- Throw if it doesn't exist.modify_block_trackblock_idtracknum$Block.modify_id(Block.set_ruler_idruler_id)-- | Merge the @from@ tracknum into the @to@ tracknum and collapse @from@.merge_track::Mm=>BlockId->TrackNum->TrackNum->m()merge_trackblock_idtofrom=dofrom_id<-get_event_track_atblock_idfrommodify_block_trackblock_idto$\btrack->btrack{Block.track_merged=Set.insertfrom_id(Block.track_mergedbtrack)}add_track_flagblock_idfromBlock.Collapse-- | Reverse 'merge_track': remove the merged tracks and expand their-- occurrances in the given block. \"Unmerge\" is not a graceful term, but at-- least it's obviously the opposite of \"merge\".unmerge_track::Mm=>BlockId->TrackNum->m()unmerge_trackblock_idtracknum=dotrack_ids<-Block.track_merged<$>get_block_track_atblock_idtracknumunmerged_tracknums<-mapMaybeM(tracknum_ofblock_id)(Set.toListtrack_ids)forM_unmerged_tracknums$\tracknum->remove_track_flagblock_idtracknumBlock.Collapseset_merged_tracksblock_idtracknummemptyset_merged_tracks::Mm=>BlockId->TrackNum->SetTrackId->m()set_merged_tracksblock_idtracknummerged=modify_block_trackblock_idtracknum$\btrack->btrack{Block.track_merged=merged}track_merged::Mm=>BlockId->TrackNum->mBooltrack_mergedblock_idtracknum=not.Set.null.Block.track_merged<$>get_block_track_atblock_idtracknum-- | Set rulers, one per track.set_ruler_ids::Mm=>BlockId->[MaybeRulerId]->m()set_ruler_idsblock_idruler_ids=modify_blockblock_id$\block->block{Block.block_tracks=zipWithset(Block.block_tracksblock)(ruler_ids++repeatNothing)}wheresettrack(Justruler_id)=track{Block.tracklike_id=Block.set_ruler_idruler_id(Block.tracklike_idtrack)}settrackNothing=track-- | Replace one RulerId with another on the given block.---- It's more convenient to do here than removing and inserting tracks, and easy-- since there's no "one per block" invariant to maintain with ruler ids.replace_ruler_id::Mm=>BlockId->RulerId->RulerId->m()replace_ruler_idblock_idfromto=modify_blockblock_id$\block->block{Block.block_tracks=mapreplace_track(Block.block_tracksblock)}wherereplace_tracktrack=track{Block.tracklike_id=replace(Block.tracklike_idtrack)}replacetlike_id|Block.ruler_id_oftlike_id==Justfrom=Block.set_ruler_idtotlike_id|otherwise=tlike_id-- | Resolve a TracklikeId to a Tracklike.get_tracklike::Mm=>Block.TracklikeId->mBlock.Tracklikeget_trackliketrack=casetrackofBlock.TIdtidrid->Block.T<$>get_tracktid<*>get_rulerridBlock.RIdrid->Block.R<$>get_rulerridBlock.DIddivider->return(Block.Ddivider)modify_block_track::Mm=>BlockId->TrackNum->(Block.Track->Block.Track)->m()modify_block_trackblock_idtracknummodify=doblock<-get_blockblock_idbtracks<-modify_at"modify_block_track"(Block.block_tracksblock)tracknummodifymodify_blockblock_id$\b->b{Block.block_tracks=btracks}-- *** track util-- | Insert a new track into Block.view_tracks, moving selections as-- appropriate. @tracknum@ is clipped to be in range.insert_into_view::Block.Block->TrackNum->Block.View->Block.Viewinsert_into_viewblocktracknumview=view{Block.view_selections=Map.map(insert_into_selectionblocktracknum)(Block.view_selectionsview)}-- | Remove @tracknum@ from Block.view_tracks, moving selections as-- appropriate. Ignored if @tracknum@ is out of range.remove_from_view::Block.Block->TrackNum->Block.View->Block.Viewremove_from_viewblocktracknumview=view{Block.view_selections=Map.mapMaybeWithKey(remove_from_selectionblocktracknum)(Block.view_selectionsview)}-- | If tracknum is before or at the selection, push it to the right. If it's-- inside, extend it. If it's to the right, do nothing.insert_into_selection::Block.Block->TrackNum->Sel.Selection->Sel.Selectioninsert_into_selectionblocktracknumsel|tracknum<=low=shift_selectionTrueblock1sel|tracknum<=high=Sel.expand_tracks1sel|otherwise=selwhere(low,high)=Sel.track_rangesel-- | Remove the given track from the selection. The selection will be moved or-- shrunk as per 'insert_into_selection', possibly to nothing if the selection-- was only on the deleted track. Config.insert_selnum is an exception, it-- moves one track to the left, if possible. That's because it's convenient to-- delete consecutive tracks.remove_from_selection::Block.Block->TrackNum->Sel.Num->Sel.Selection->MaybeSel.Selectionremove_from_selectionblocktracknumselnumsel|tracknum<low=Just$shift_selectionTrueblock(-1)sel|tracknum==high&&high==low=ifselnum==Config.insert_selnumthenJust$shift_selectionTrueblock(-1)selelseNothing|tracknum<=high=Just$Sel.expand_tracks(-1)sel|otherwise=Justselwhere(low,high)=Sel.track_rangesel-- | Shift the selection, clipping if it's out of range. While the-- sel_cur_track won't be on a non-selectable track after this, the selection-- may still include one.shift_selection::Bool-- ^ skip unselectable tracks->Block.Block->TrackNum->Sel.Selection->Sel.Selectionshift_selectionskip_unselectableblockshiftsel=Sel.modify_tracks(+shift2)selwhereshift2|skip_unselectable=skip_unselectable_tracksblock(Sel.cur_tracksel)shift-Sel.cur_tracksel|otherwise=shift-- | Shift a tracknum to another track, skipping unselectable tracks.skip_unselectable_tracks::Block.Block->TrackNum->Int->TrackNumskip_unselectable_tracksblocktracknumshift|shift==0=tracknum|shift>0=find_track(dropWhile(<tracknum)selectable)|otherwise=find_track(dropWhile(>tracknum)(List.reverseselectable))whereselectable=selectable_tracksblockfind_track[]=tracknumfind_tracktracks@(first:_)=fromMaybetracknum$Seq.head$dropabs_shifttrackswhereabs_shift=iftracknum/=firstthenabsshift-1elseabsshift-- | Get the tracknums from a block that should be selectable.selectable_tracks::Block.Block->[TrackNum]selectable_tracksblock=[tracknum|(tracknum,track)<-zip[0..](Block.block_tracksblock),Block.track_selectabletrack]-- ** utilset_block::Mm=>BlockId->Block.Block->m()set_blockblock_idblock=unsafe_modify$\st->st{state_blocks=Map.adjust(constblock)block_id(state_blocksst)}modify_block::Mm=>BlockId->(Block.Block->Block.Block)->m()modify_blockblock_idf=doblock<-get_blockblock_idset_blockblock_id(fblock)-- * trackget_track::Mm=>TrackId->mTrack.Trackget_tracktrack_id=get>>=lookup_idtrack_id.state_trackslookup_track::Mm=>TrackId->m(MaybeTrack.Track)lookup_tracktrack_id=gets(Map.lookuptrack_id.state_tracks)all_track_ids::Mm=>m[TrackId]all_track_ids=gets(Map.keys.state_tracks)-- | Insert the given track with the given ID.---- Throw if the TrackId already exists.create_track::Mm=>Id.Id->Track.Track->mTrackIdcreate_trackidtrack=dotrack_id<-insert(Id.TrackIdid)trackstate_tracks$\tracksst->st{state_tracks=tracks}-- Since I don't diff events but rely on changes being recorded here,-- I have to mark this track as having new events. Otherwise, if the same-- TrackId is destroyed and recreated then diff won't notice the changed-- events.update$Update.CmdTrackAllEventstrack_idreturntrack_id-- | Destroy the track and remove it from all the blocks it's in. No-op if-- the TrackId doesn't exist.destroy_track::Mm=>TrackId->m()destroy_tracktrack_id=doblocks<-blocks_with_track_idtrack_idforM_blocks$\(block_id,tracks)->forM_tracks$\(tracknum,_)->remove_trackblock_idtracknumunsafe_modify$\st->st{state_tracks=Map.deletetrack_id(state_tracksst)}get_track_title::Mm=>TrackId->mTextget_track_title=(Track.track_title<$>).get_trackset_track_title::Mm=>TrackId->Text->m()set_track_titletrack_idtext=modify_track_titletrack_id(consttext)modify_track_title::Mm=>TrackId->(Text->Text)->m()modify_track_titletrack_idf=modify_tracktrack_id$\track->track{Track.track_title=f(Track.track_titletrack)}set_track_bg::Mm=>TrackId->Color.Color->m()set_track_bgtrack_idcolor=modify_tracktrack_id$\track->track{Track.track_bg=color}modify_track_render::Mm=>TrackId->(Track.RenderConfig->Track.RenderConfig)->m()modify_track_rendertrack_idf=modify_tracktrack_id$\track->track{Track.track_render=f(Track.track_rendertrack)}set_render_style::Mm=>Track.RenderStyle->TrackId->m()set_render_stylestyletrack_id=modify_track_rendertrack_id$\render->render{Track.render_style=style}-- | Find @track_id@ in all the blocks it exists in, and return the track info-- for each tracknum at which @track_id@ lives. Blocks with no matching tracks-- won't be returned, so the return track lists will always be non-null.blocks_with_track_id::Mm=>TrackId->m[(BlockId,[(TrackNum,Block.TracklikeId)])]blocks_with_track_idtrack_id=find_tracks((==Justtrack_id).Block.track_id_of)<$>getsstate_blocks-- ** events{- There are two interpretations of a range: the strict one is that when
start==end nothing can be selected. A more relaxed one is that start==end
will still select an event at start. The relaxed one is often convenient
for commands, so there are typically three variants of each ranged command:
select events in the strict half-open range (functions end with _range),
select an event at a certain point (functions use the singular), and select
events in the relaxed half-open range (functions use the plural).
-}-- | Insert events into track_id as per 'Events.insert'.insert_events::Mm=>TrackId->[Event.Event]->m()insert_eventstrack_idevents_=_modify_eventstrack_id$\old_events->(Events.inserteventsold_events,events_rangeevents)whereevents=mapclip_negative$dropWhile((<0).Event.start)events_clip_negativeevent|Event.endevent<0=Event.set_end0event|otherwise=event{- | Like 'insert_events', but clip the events to the end of a block.
This is necessarily block specific, because block duration is defined by its
ruler. Still, you should use this in preference to 'insert_events'.
This uses 'block_end', which means that if events don't already go past the
end of the ruler, they won't after this is called. If they are already
past (e.g. there is no ruler), then they will only be clipped if they move
to later in time. This might be confusing, but it seems generally
convenient to not have to constantly manually trim events when they get
moved past the end of the ruler, but definitely inconvenient for events to
just disappear when there is no ruler.
-}insert_block_events::Mm=>BlockId->TrackId->[Event.Event]->m()insert_block_eventsblock_idtrack_idevents=doend<-block_endblock_id-- allow_zero=True because zero-dur events at the end of a block are used-- for negative/final notes.insert_eventstrack_id(Events.clipTrueendevents)insert_event::Mm=>TrackId->Event.Event->m()insert_eventtrack_idevent=insert_eventstrack_id[event]get_events::Mm=>TrackId->mEvents.Eventsget_eventstrack_id=Track.track_events<$>get_tracktrack_id-- | Modify the events on a track, and assume the entire track has been-- damaged.modify_events::Mm=>TrackId->(Events.Events->Events.Events)->m()modify_eventstrack_idf=_modify_eventstrack_id$\events->(fevents,Ranges.everything)modify_events_range::Mm=>TrackId->Events.Range->(Events.Events->Events.Events)->m()modify_events_rangetrack_idrangemodify=_modify_eventstrack_id$\events->(processevents,uncurryRanges.range(Events.range_timesrange))where-- A range to the end should be inclusive, because I frequently have a-- positive event at the end.processevents=(pre<>modifywithin<>post)where(pre,within,post)=Events.split_rangerangeeventsmodify_events_from::Mm=>TrackId->TrackTime->(Events.Events->Events.Events)->m()modify_events_fromtrack_idstartmodify=dorange<-range_fromtrack_idstartmodify_events_rangetrack_idrangemodify-- | Just like 'modify_events', except that it expects you only modified a few-- events, and will only emit damage for the changed parts.modify_some_events::Mm=>TrackId->(Events.Events->Events.Events)->m()modify_some_eventstrack_idf=_modify_eventstrack_id$\events->letnew_events=feventsin(new_events,calculate_damageeventsnew_events)calculate_damage::Events.Events->Events.Events->Ranges.RangesTrackTimecalculate_damageoldnew=Ranges.sorted_ranges$foldrf[]$Seq.pair_sorted_onEvent.start(Events.ascendingold)(Events.ascendingnew)wheref(Seq.Secondnew)ranges=Event.rangenew:rangesf(Seq.Firstold)ranges=Event.rangeold:rangesf(Seq.Botholdnew)ranges|old==new=ranges|otherwise=(Event.startold,max(Event.endold)(Event.endnew)):ranges-- | Remove a single event by start and orientation.-- TODO I think 'remove_events_range' is now just as expressive and can be just-- as efficientremove_event::Mm=>TrackId->Event.Event->m()remove_eventtrack_idevent=_modify_eventstrack_id$\events->caseEvents.att(Event.orientationevent)eventsofNothing->(events,Ranges.nothing)Justevent->(Events.remove(Events.Pointt(Event.orientationevent))events,events_range[event])wheret=Event.startevent-- | Just like @mapM_ (remove_event track_id)@ but more efficient.-- TODO at least I hope, it got sort of complicated.remove_events::Mm=>TrackId->[Event.Event]->m()remove_events_[]=return()remove_eventstrack_id[event]=remove_eventtrack_ideventremove_eventstrack_idevents=doremove_events_rangetrack_id$Events.Range(Event.minfirst)(Event.maxlast)when(Event.is_negativefirst)$remove_eventtrack_idfirstwhen(Event.is_positivelast)$remove_eventtrack_idlastwhere-- Events is non-empty due to the pattern match above.Justfirst=Seq.minimum_onEvent.starteventsJustlast=Seq.maximum_onEvent.starteventsremove_events_range::Mm=>TrackId->Events.Range->m()remove_events_rangetrack_idrange=modify_events_rangetrack_idrange(constmempty)-- | Get the end of the last event of the block.track_event_end::Mm=>TrackId->mTrackTimetrack_event_end=fmapEvents.time_end.get_eventsrange_from::Mm=>TrackId->TrackTime->mEvents.Rangerange_fromtrack_idstart=Events.Rangestart.(+1)<$>track_event_endtrack_id-- +1 to get a final 0 dur positive event.-- | Emit track updates for all tracks. Use this when events have changed but-- I don't know which ones, e.g. when loading a file or restoring a previous-- state.update_all_tracks::Mm=>m()update_all_tracks=dost<-getmapM_(update.Update.CmdTrackAllEvents)(Map.keys(state_tracksst))-- ** util-- | Don't use this to modify the events, because it won't create damage.-- TODO should I try to protect against that?modify_track::Mm=>TrackId->(Track.Track->Track.Track)->m()modify_tracktrack_idf=doget_tracktrack_id-- Throw if track_id doesn't exist.unsafe_modify$\st->st{state_tracks=Map.adjustftrack_id(state_tracksst)}_modify_events::Mm=>TrackId->(Events.Events->(Events.Events,Ranges.RangesTrackTime))->m()_modify_eventstrack_idf=dotrack<-get_tracktrack_idlet(new_events,ranges)=f(Track.track_eventstrack)new_track=track{Track.track_events=new_events}unsafe_modify$\st->st{state_tracks=Map.inserttrack_idnew_track(state_tracksst)}-- Force out whatever transformations might be in the new events. The-- main reason is to force out any IO exceptions that might be hiding in-- REPL expressions, but it seems better for memory in general to keep-- State in normal form.DeepSeq.deepseqnew_events$mapM_update(ranges_to_updatestrack_idranges)ranges_to_updates::TrackId->Ranges.RangesTrackTime->[Update.CmdUpdate]ranges_to_updatestrack_idranges=caseRanges.extractrangesofNothing->[Update.CmdTrackAllEventstrack_id]Justpairs->[Update.CmdTrackEventstrack_idse|(s,e)<-pairs]events_range::[Event.Event]->Ranges.RangesTrackTimeevents_rangeevents=caseminmaxeventsofJust(emin,emax)->Ranges.rangeeminemaxNothing->Ranges.nothingwhereminmax(e:es)=Just$go(Event.mine)(Event.maxe)esminmax[]=Nothinggo!emin!emax(e:es)=go(minemin(Event.mine))(maxemax(Event.maxe))esgoeminemax[]=(emin,emax)-- * rulerget_ruler::Mm=>RulerId->mRuler.Rulerget_rulerruler_id|ruler_id==no_ruler=returnRuler.no_ruler|otherwise=get>>=lookup_idruler_id.state_rulerslookup_ruler::Mm=>RulerId->m(MaybeRuler.Ruler)lookup_rulerruler_id=get>>=return.Map.lookupruler_id.state_rulersall_ruler_ids::Mm=>m[RulerId]all_ruler_ids=gets(Map.keys.state_rulers)-- | Insert the given ruler with the given ID.---- Throw if the RulerId already exists.create_ruler::Mm=>Id.Id->Ruler.Ruler->mRulerIdcreate_ruleridruler-- no_ruler is global and assumed to always exist.|id==Id.unpack_idno_ruler=throw"can't insert no-ruler"|otherwise=insert(Id.RulerIdid)rulerstate_rulers$\rulersst->st{state_rulers=rulers}-- | Destroy the ruler and remove it from all the blocks it's in.destroy_ruler::Mm=>RulerId->m()destroy_rulerruler_id=doblocks<-blocks_with_ruler_idruler_idforM_blocks$\(block_id,tracks)->dolettracknums=mapfsttrackssetri=ifi`elem`tracknumsthenBlock.set_ruler_idno_rulerelseidderuler(i,track)=Block.modify_id(setri)trackmodify_blockblock_id$\block->block{Block.block_tracks=mapderuler(Seq.enumerate(Block.block_tracksblock))}unsafe_modify$\st->st{state_rulers=Map.deleteruler_id(state_rulersst)}modify_ruler::Mm=>RulerId->(Ruler.Ruler->EitherTextRuler.Ruler)->m()modify_rulerruler_idmodify=dowhen(ruler_id==no_ruler)$throw"can't modify no_ruler"ruler<-get_rulerruler_idletmsg="modify_ruler "<>prettyruler_id<>": "modified<-require_right(msg<>)$modifyrulerunsafe_modify$\st->st{state_rulers=Map.insertruler_idmodified(state_rulersst)}update$Update.CmdRulerruler_idruler_of::Mm=>BlockId->mRulerIdruler_ofblock_id=require("no ruler in "<>showtblock_id)=<<Seq.head.Block.block_ruler_ids<$>get_blockblock_idrulers_of::Mm=>BlockId->m[RulerId]rulers_ofblock_id=Seq.unique.Block.block_ruler_ids<$>get_blockblock_id-- | Just like 'blocks_with_track_id' except for ruler_id.blocks_with_ruler_id::Mm=>RulerId->m[(BlockId,[(TrackNum,Block.TracklikeId)])]blocks_with_ruler_idruler_id=find_tracks((==Justruler_id).Block.ruler_id_of)<$>getsstate_blocks-- | Since all TracklikeIds must have a ruler, all States have a special empty-- ruler that can be used in a \"no ruler\" situation.---- This RulerId is implicitly present in every block. It's not actually in-- 'state_rulers' to avoid it getting renamed or deleted, but 'get_ruler' will-- pretend it exists. As long as everyone that cares about no_ruler (which is-- only 'verify' and 'get_tracklike' for "Ui.Sync") uses 'get_ruler' then-- they won't be confused by tracks that have no_ruler.no_ruler::RulerIdno_ruler=Id.RulerId(Id.global"-no-ruler-")-- * utilfind_tracks::(Block.TracklikeId->Bool)->MapBlockIdBlock.Block->[(BlockId,[(TrackNum,Block.TracklikeId)])]find_tracksfblocks=do(bid,b)<-Map.assocsblockslettracks=get_tracksbguard(not(nulltracks))return(bid,tracks)whereall_tracksblock=Seq.enumerate(Block.block_tracksblock)get_tracksblock=[(tracknum,Block.tracklike_idtrack)|(tracknum,track)<-all_tracksblock,f(Block.tracklike_idtrack)]-- | Lookup @map!key@, throwing if it doesn't exist.lookup_id::(Ordk,Showk,Mm)=>k->Mapka->malookup_idkeymap=caseMap.lookupkeymapofNothing->throw$"State.lookup: unknown "<>showtkeyJustval->returnval-- | Insert @val@ at @key@ in @get_map state@, throwing if it already exists.-- Put the map back into @state@ by applying @set_map new_map state@ to it.insert::(Mm,Ordk,Showk)=>k->a->(State->Mapka)->(Mapka->State->State)->mkinsertkeyvalget_mapset_map=dostate<-getwhen(key`Map.member`get_mapstate)$throw$showtkey<>" already exists"unsafe_put(set_map(Map.insertkeyval(get_mapstate))state)returnkey-- | Modify the @i@th element of @xs@ by applying @f@ to it.modify_at::Mm=>Text->[a]->Int->(a->a)->m[a]modify_atmsgxsif=casepostof[]->throw$msg<>": can't replace index "<>showti<>" of list with length "<>showt(lengthxs)(elt:rest)->return(pre++felt:rest)where(pre,post)=splitAtixs-- * verify-- | Run a @fix_*@ function, and throw an error if it found problems.validate::Mm=>Text->StateId[Text]->m()validatecallerverify=dostate<-getcaserun_idstateverifyofLefterr->throw$caller<>": error validating: "<>showterrRight(errs,state,_)|nullerrs->return()|otherwise->do-- The exception should cause the state to be rolled back, but-- I might as well not let a known broken state stick around.putstatethrow$caller<>": error validating: "<>Text.intercalate"; "errs-- | Unfortunately there are some invariants to protect within State.-- They can all be fixed by dropping things, so this will fix them and return-- a list of warnings.verify::State->(State,[Text])verifystate=caserun_idstatefix_stateofLefterr->(state,["exception: "<>prettyerr])Right(errs,state,_)->(state,errs)-- | This is like 'verify', but less complete. It returns Left if it wants-- you to reject the new state entirely.---- 'verify' is better, but more expensive, so I'm reluctant to run it on every-- single cmd. If I run 'verify' before unsafe puts and trust this module to-- maintain invariants then I don't need to, but I don't fully trust this-- module.---- TODO a better approach would be to make sure Sync can't be broken by State.quick_verify::State->EitherString(State,[Text])quick_verifystate=caserun_idstatequick_fixofLefterr->Left$prettyserrRight(errs,state,_)->Right(state,errs)wherequick_fix=domapM_verify_block=<<gets(Map.elems.state_blocks)-- Disappearing views can happen if you undo past a block rename.-- In that case I should track the rename rather than disappearing-- the view, but in any case I don' want dangling ViewIds and-- disappearing the view is relatively harmless.views<-gets(Map.toList.state_views)concatMapM(uncurryverify_view)viewsverify_blockblock=domapM_get_track(Block.block_track_idsblock)mapM_get_ruler(Block.block_ruler_idsblock)fix_state::StateId[Text]fix_state=doviews<-gets(Map.toList.state_views)view_errs<-concatMapM(uncurryverify_view)viewsblocks<-gets(Map.toList.state_blocks)block_errs<-concatMapM(uncurryfix_block)blocksreturn$view_errs++block_errs-- | Drop views with invalid BlockIds.verify_view::ViewId->Block.View->StateId[Text]verify_viewview_idview=doblock<-lookup_block(Block.view_blockview)caseblockofJust_->return[]Nothing->dodestroy_viewview_idreturn[showtview_id<>": dropped because of invalid "<>showt(Block.view_blockview)]fix_block::BlockId->Block.Block->StateId[Text]fix_blockblock_idblock=map((showtblock_id<>": ")<>).mconcat<$>sequence[fix_track_idsblock_idblock,unique_track_idsblock_idblock,fix_ruler_idsblock_idblock,fix_skeletonblock_idblock,concatMapM(fix_mergedblock_id)tracks,fix_integrated_blockblock_idblock,fix_integrated_tracksblock_idblock]wheretracks=zip[0..](Block.block_tracksblock)-- | Drop invalid track ids.fix_track_ids::BlockId->Block.Block->StateId[Text]fix_track_idsblock_idblock=doall_track_ids<-getsstate_tracksletis_valid=(`Map.member`all_track_ids)letinvalid=filter(not.is_valid.snd)(block_event_tracknumsblock)mapM_(remove_trackblock_id.fst)invalidreturn["tracknum "<>showttracknum<>": dropped invalid "<>showttrack_id|(tracknum,track_id)<-invalid]-- | Replace invalid ruler ids with no_ruler.fix_ruler_ids::BlockId->Block.Block->StateId[Text]fix_ruler_ids_block_id_block=return[]-- TODO-- | Each TrackId of a block is unique.unique_track_ids::BlockId->Block.Block->StateId[Text]unique_track_idsblock_idblock=doletinvalid=concatMapsnd$snd$Seq.partition_dupssnd(block_event_tracknumsblock)mapM_(remove_trackblock_id.fst)invalidreturn["tracknum "<>showttracknum<>": dropped duplicate "<>showttrack_id|(tracknum,track_id)<-invalid]-- | Skeleton tracknums in range.fix_skeleton::BlockId->Block.Block->StateId[Text]fix_skeleton_block_id_block=return[]-- TODO-- | Strip invalid Block.track_merged.fix_merged::BlockId->(TrackNum,Block.Track)->StateId[Text]fix_mergedblock_id(tracknum,track)=doall_track_ids<-getsstate_tracksletis_valid=(`Map.member`all_track_ids)let(valid,invalid)=Set.partitionis_valid(Block.track_mergedtrack)unless(Set.nullinvalid)$modify_block_trackblock_idtracknum(const$track{Block.track_merged=valid})return["tracknum "<>showttracknum<>": stripped invalid merged "<>showttrack_id|track_id<-Set.toListinvalid]-- | Drop block_integrated if the source BlockId doesn't exist, and strip out-- TrackDestinations whose TrackIds aren't in this block.fix_integrated_block::BlockId->Block.Block->StateId[Text]fix_integrated_blockblock_idblock=doblocks<-getsstate_blockslet(integrated,errs)=fixblocks(Block.block_integratedblock)unless(nullerrs)$modify_blockblock_id$\block->block{Block.block_integrated=integrated}returnerrswheretrack_ids=Block.block_track_idsblockfix_Nothing=(Nothing,[])fixblocks(Just(source_id,dests))=caseMap.lookupsource_idblocksofNothing->(Nothing,["removed invalid integrated block: "<>showtsource_id])Justsource->(Just(source_id,valid),errs)where(valid,errs)=fix_track_destinations("block of "<>showtsource_id)(Block.block_track_idssource)track_idsdests-- | Drop integrated tracks whose source TrackId isn't in this block, and-- TrackDestinations whose TrackIds aren't in this block.---- TODO-- - No TrackIds duplicated between DeriveDestinations.-- - No TrackIds duplicated across integrated tracks.fix_integrated_tracks::BlockId->Block.Block->StateId[Text]fix_integrated_tracksblock_idblock=dolet(dests,errs)=Maybe.catMaybes***concat$unzip$mapfix(Block.block_integrated_tracksblock)unless(nullerrs)$modify_blockblock_id$\block->block{Block.block_integrated_tracks=dests}returnerrswheretrack_ids=Block.block_track_idsblockfix(track_id,dests)|track_id`notElem`track_ids=(Nothing,["removed invalid integrated track: "<>showttrack_id])|otherwise=(Just(track_id,valid),errs)where(valid,errs)=fix_track_destinations("track of "<>showttrack_id)track_idstrack_idsdestsfix_track_destinations::Text->[TrackId]->[TrackId]->Block.TrackDestinations->(Block.TrackDestinations,[Text])fix_track_destinationserr_msgsource_track_idstrack_idsd=casedofBlock.DeriveDestinationsdests->(Block.DeriveDestinationsvalid,errs(mapderive_track_idsinvalid))where(valid,invalid)=List.partitionderive_validdestsBlock.ScoreDestinationsdests->(Block.ScoreDestinationsvalid,errs(mapscore_track_idsinvalid))where(valid,invalid)=List.partitionscore_validdestswhereerrsinvalid=["integrated "<>err_msg<>": track destination has track ids not in the right block: "<>prettydest|dest<-invalid]derive_track_ids(Block.NoteDestinationnotecontrols)=fstnote:mapfst(Map.elemscontrols)score_track_ids(source_id,(dest_id,_))=(source_id,dest_id)derive_valid(Block.NoteDestinationnotecontrols)=all(`elem`track_ids)(fstnote:mapfst(Map.elemscontrols))score_valid(source_id,(dest_id,_index))=source_id`elem`source_track_ids&&dest_id`elem`track_idsblock_event_tracknums::Block.Block->[(TrackNum,TrackId)]block_event_tracknumsblock=[(tracknum,track_id)|(tracknum,Justtrack_id)<-zip[0..]track_ids]wheretrack_ids=mapBlock.track_id(Block.block_tracksblock)-- * IDs-- | Read an ID of the form \"namespace/name\", or just \"name\", filling in-- the current namespace if it's not present.read_id::(CallStack.Stack,Id.Identa,Mm)=>Text->maread_idname=dons<-get_namespacerequire("invalid characters in id name: "<>showtname)$Id.make$Id.idnsnamenamespace::Mm=>Text->mId.Namespacenamespacens=dounless(Id.valid_symbolns)$throw$"invalid characters in namespace: "<>showtnsreturn$Id.namespacens