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

module Ui.Block (
    -- * Block
    Block(..)
    , Skeleton(..)
    , Meta, TrackDestinations(..), ScoreDestinations, NoteDestination(..)
    , dest_track_ids, note_dest_track_ids, empty_destination
    , Source(..), destination_to_source
    , ManualDestinations, SourceKey
    , EventIndex, short_event_index
    , integrate_skeleton
    , block_tracklike_ids, block_track_ids, block_ruler_ids
    , block
    , Config(..), default_config
    , Box(..)
    -- * Track
    , Track(..), track_id, track
    , modify_id
    , divider
    , track_collapsed, track_selectable, track_wants_signal
    -- ** DisplayTrack
    , DisplayTrack(..), Status(..), empty_status, TrackFlag(..)
    , block_display_tracks
    , display_track_width
    , flags_to_status, flag_char
    -- ** TracklikeId
    , TracklikeId(..)
    , track_id_of, track_ids_of, ruler_id_of, ruler_ids_of
    , set_ruler_id
    , Tracklike(..)
    , track_of, tracks_of, ruler_of, rulers_of
    , Divider(..)
    -- * View
    , View(..)
    , view
    , Padding(..)
    , status_color, show_status
    , visible_track, visible_time
    , track_rect, set_track_rect
    , view_visible_time, view_visible_track
    , screen_pixels
) where
import qualified Control.DeepSeq as DeepSeq
import qualified Data.Char as Char
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Text as Text

import qualified GHC.Generics as Generics

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

import qualified App.Config as Config
import qualified Ui.Color as Color
import qualified Ui.Event as Event
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.Zoom as Zoom

import           Global
import           Types


-- * block

-- | This is the data behind a single block.
data Block = Block {
    Block -> Text
block_title :: !Text
    , Block -> Config
block_config :: !Config
    , Block -> [Track]
block_tracks :: ![Track]
    , Block -> Skeleton
block_skeleton :: !Skeleton.Skeleton
    -- | Present if this block was integrated from another.  If the
    -- TrackDestinations is empty, then this is an empty block that was created
    -- to receive integration.
    , Block -> Maybe (BlockId, TrackDestinations)
block_integrated :: !(Maybe (BlockId, TrackDestinations))

    -- | Each pair is a set of tracks integrated from a source TrackId.
    -- A single source can have multiple destination sets.  Similar to
    -- block_integrated, if the TrackDestinations is empty, then new integrated
    -- tracks should be created.
    , Block -> [(TrackId, TrackDestinations)]
block_integrated_tracks :: ![(TrackId, TrackDestinations)]
    , Block -> ManualDestinations
block_integrated_manual :: !ManualDestinations
    , Block -> Meta
block_meta :: !Meta
    } deriving (Block -> Block -> Bool
(Block -> Block -> Bool) -> (Block -> Block -> Bool) -> Eq Block
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Block -> Block -> Bool
$c/= :: Block -> Block -> Bool
== :: Block -> Block -> Bool
$c== :: Block -> Block -> Bool
Eq, Int -> Block -> ShowS
[Block] -> ShowS
Block -> String
(Int -> Block -> ShowS)
-> (Block -> String) -> ([Block] -> ShowS) -> Show Block
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Block] -> ShowS
$cshowList :: [Block] -> ShowS
show :: Block -> String
$cshow :: Block -> String
showsPrec :: Int -> Block -> ShowS
$cshowsPrec :: Int -> Block -> ShowS
Show, (forall x. Block -> Rep Block x)
-> (forall x. Rep Block x -> Block) -> Generic Block
forall x. Rep Block x -> Block
forall x. Block -> Rep Block x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Block x -> Block
$cfrom :: forall x. Block -> Rep Block x
Generics.Generic)

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

instance DeepSeq.NFData Block where
    rnf :: Block -> ()
rnf = Text -> ()
forall a. NFData a => a -> ()
DeepSeq.rnf (Text -> ()) -> (Block -> Text) -> Block -> ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block -> Text
block_title

data Skeleton = Explicit | Implicit
    deriving (Skeleton -> Skeleton -> Bool
(Skeleton -> Skeleton -> Bool)
-> (Skeleton -> Skeleton -> Bool) -> Eq Skeleton
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Skeleton -> Skeleton -> Bool
$c/= :: Skeleton -> Skeleton -> Bool
== :: Skeleton -> Skeleton -> Bool
$c== :: Skeleton -> Skeleton -> Bool
Eq, Int -> Skeleton -> ShowS
[Skeleton] -> ShowS
Skeleton -> String
(Int -> Skeleton -> ShowS)
-> (Skeleton -> String) -> ([Skeleton] -> ShowS) -> Show Skeleton
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Skeleton] -> ShowS
$cshowList :: [Skeleton] -> ShowS
show :: Skeleton -> String
$cshow :: Skeleton -> String
showsPrec :: Int -> Skeleton -> ShowS
$cshowsPrec :: Int -> Skeleton -> ShowS
Show)
instance Pretty Skeleton where pretty :: Skeleton -> Text
pretty = Skeleton -> Text
forall a. Show a => a -> Text
showt

{- | Block metadata is extra data that doesn't affect normal derivation, but
    may be of interest to cmds.

    Previously this was used to mark blocks for automatic lilypond derivation,
    currently tscore uses it to mark sub-blocks.
-}
type Meta = Map Text Text

data Source =
    -- | Integrated from a manually-invoked integration.  A single SourceKey
    -- can have destinations on multiple tracks within the block.
    ManualSource !SourceKey
    | TrackSource !TrackId
    | BlockSource !BlockId
    deriving (Source -> Source -> Bool
(Source -> Source -> Bool)
-> (Source -> Source -> Bool) -> Eq Source
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Source -> Source -> Bool
$c/= :: Source -> Source -> Bool
== :: Source -> Source -> Bool
$c== :: Source -> Source -> Bool
Eq, Eq Source
Eq Source
-> (Source -> Source -> Ordering)
-> (Source -> Source -> Bool)
-> (Source -> Source -> Bool)
-> (Source -> Source -> Bool)
-> (Source -> Source -> Bool)
-> (Source -> Source -> Source)
-> (Source -> Source -> Source)
-> Ord Source
Source -> Source -> Bool
Source -> Source -> Ordering
Source -> Source -> Source
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Source -> Source -> Source
$cmin :: Source -> Source -> Source
max :: Source -> Source -> Source
$cmax :: Source -> Source -> Source
>= :: Source -> Source -> Bool
$c>= :: Source -> Source -> Bool
> :: Source -> Source -> Bool
$c> :: Source -> Source -> Bool
<= :: Source -> Source -> Bool
$c<= :: Source -> Source -> Bool
< :: Source -> Source -> Bool
$c< :: Source -> Source -> Bool
compare :: Source -> Source -> Ordering
$ccompare :: Source -> Source -> Ordering
Ord, Int -> Source -> ShowS
[Source] -> ShowS
Source -> String
(Int -> Source -> ShowS)
-> (Source -> String) -> ([Source] -> ShowS) -> Show Source
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Source] -> ShowS
$cshowList :: [Source] -> ShowS
show :: Source -> String
$cshow :: Source -> String
showsPrec :: Int -> Source -> ShowS
$cshowsPrec :: Int -> Source -> ShowS
Show)

instance Pretty Source where
    pretty :: Source -> Text
pretty (ManualSource Text
key) = Text
key
    pretty (TrackSource TrackId
tid) = TrackId -> Text
forall a. Pretty a => a -> Text
pretty TrackId
tid
    pretty (BlockSource BlockId
bid) = BlockId -> Text
forall a. Pretty a => a -> Text
pretty BlockId
bid

-- | TODO I intended to unify all the integration muddle into one dest to
-- source map, and maybe I stil can, but meanwhile, here's what it could look
-- like.
destination_to_source :: Block -> [(TrackId, (Source, EventIndex))]
destination_to_source :: Block -> [(TrackId, (Source, EventIndex))]
destination_to_source Block
block = [[(TrackId, (Source, EventIndex))]]
-> [(TrackId, (Source, EventIndex))]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ case Block -> Maybe (BlockId, TrackDestinations)
block_integrated Block
block of
        Maybe (BlockId, TrackDestinations)
Nothing -> []
        Just (BlockId
source_block, TrackDestinations
tdests) ->
            Source -> TrackDestinations -> [(TrackId, (Source, EventIndex))]
track_dests (BlockId -> Source
BlockSource BlockId
source_block) TrackDestinations
tdests
    , [(TrackId, TrackDestinations)] -> [(TrackId, (Source, EventIndex))]
integrated_tracks (Block -> [(TrackId, TrackDestinations)]
block_integrated_tracks Block
block)
    , ManualDestinations -> [(TrackId, (Source, EventIndex))]
forall {t :: * -> *}.
Foldable t =>
Map Text (t NoteDestination) -> [(TrackId, (Source, EventIndex))]
integrated_manual (Block -> ManualDestinations
block_integrated_manual Block
block)
    ]
    where
    integrated_tracks :: [(TrackId, TrackDestinations)] -> [(TrackId, (Source, EventIndex))]
integrated_tracks [(TrackId, TrackDestinations)]
itracks = [[(TrackId, (Source, EventIndex))]]
-> [(TrackId, (Source, EventIndex))]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ Source -> TrackDestinations -> [(TrackId, (Source, EventIndex))]
track_dests (TrackId -> Source
TrackSource TrackId
source_track) TrackDestinations
tdests
        | (TrackId
source_track, TrackDestinations
tdests) <- [(TrackId, TrackDestinations)]
itracks
        ]
    integrated_manual :: Map Text (t NoteDestination) -> [(TrackId, (Source, EventIndex))]
integrated_manual Map Text (t NoteDestination)
manual = [[(TrackId, (Source, EventIndex))]]
-> [(TrackId, (Source, EventIndex))]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ (NoteDestination -> [(TrackId, (Source, EventIndex))])
-> t NoteDestination -> [(TrackId, (Source, EventIndex))]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Source -> NoteDestination -> [(TrackId, (Source, EventIndex))]
forall {a}. a -> NoteDestination -> [(TrackId, (a, EventIndex))]
note_dest (Text -> Source
ManualSource Text
source_key)) t NoteDestination
ndests
        | (Text
source_key, t NoteDestination
ndests) <- Map Text (t NoteDestination) -> [(Text, t NoteDestination)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Text (t NoteDestination)
manual
        ]
    track_dests :: Source -> TrackDestinations -> [(TrackId, (Source, EventIndex))]
track_dests Source
source (DeriveDestinations [NoteDestination]
ndests) =
        (NoteDestination -> [(TrackId, (Source, EventIndex))])
-> [NoteDestination] -> [(TrackId, (Source, EventIndex))]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Source -> NoteDestination -> [(TrackId, (Source, EventIndex))]
forall {a}. a -> NoteDestination -> [(TrackId, (a, EventIndex))]
note_dest Source
source) [NoteDestination]
ndests
    track_dests Source
_source (ScoreDestinations ScoreDestinations
sdests) =
        [ (TrackId
dest_track, (TrackId -> Source
TrackSource TrackId
source_track, EventIndex
index))
        | (TrackId
source_track, (TrackId
dest_track, EventIndex
index)) <- ScoreDestinations
sdests
        ]
    note_dest :: a -> NoteDestination -> [(TrackId, (a, EventIndex))]
note_dest a
source (NoteDestination Text
_key (TrackId, EventIndex)
note Map Text (TrackId, EventIndex)
controls) =
        ((TrackId, EventIndex) -> TrackId
forall a b. (a, b) -> a
fst (TrackId, EventIndex)
note, (a
source, (TrackId, EventIndex) -> EventIndex
forall a b. (a, b) -> b
snd (TrackId, EventIndex)
note))
            (TrackId, (a, EventIndex))
-> [(TrackId, (a, EventIndex))] -> [(TrackId, (a, EventIndex))]
forall a. a -> [a] -> [a]
: [(TrackId
tid, (a
source, EventIndex
index)) | (TrackId
tid, EventIndex
index) <- Map Text (TrackId, EventIndex) -> [(TrackId, EventIndex)]
forall k a. Map k a -> [a]
Map.elems Map Text (TrackId, EventIndex)
controls]

data TrackDestinations =
    -- | A derive integrate can produce multiple note tracks, and each one gets
    -- its own NoteDestination.  The TrackIds in here should point to tracks
    -- within the block that contains the TrackDestinations.
    DeriveDestinations ![NoteDestination]
    -- | A score integrate is always just one track along with its descendents.
    -- It's not necessarily a note track.
    | ScoreDestinations !ScoreDestinations
    deriving (TrackDestinations -> TrackDestinations -> Bool
(TrackDestinations -> TrackDestinations -> Bool)
-> (TrackDestinations -> TrackDestinations -> Bool)
-> Eq TrackDestinations
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TrackDestinations -> TrackDestinations -> Bool
$c/= :: TrackDestinations -> TrackDestinations -> Bool
== :: TrackDestinations -> TrackDestinations -> Bool
$c== :: TrackDestinations -> TrackDestinations -> Bool
Eq, Int -> TrackDestinations -> ShowS
[TrackDestinations] -> ShowS
TrackDestinations -> String
(Int -> TrackDestinations -> ShowS)
-> (TrackDestinations -> String)
-> ([TrackDestinations] -> ShowS)
-> Show TrackDestinations
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TrackDestinations] -> ShowS
$cshowList :: [TrackDestinations] -> ShowS
show :: TrackDestinations -> String
$cshow :: TrackDestinations -> String
showsPrec :: Int -> TrackDestinations -> ShowS
$cshowsPrec :: Int -> TrackDestinations -> ShowS
Show, ReadPrec [TrackDestinations]
ReadPrec TrackDestinations
Int -> ReadS TrackDestinations
ReadS [TrackDestinations]
(Int -> ReadS TrackDestinations)
-> ReadS [TrackDestinations]
-> ReadPrec TrackDestinations
-> ReadPrec [TrackDestinations]
-> Read TrackDestinations
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [TrackDestinations]
$creadListPrec :: ReadPrec [TrackDestinations]
readPrec :: ReadPrec TrackDestinations
$creadPrec :: ReadPrec TrackDestinations
readList :: ReadS [TrackDestinations]
$creadList :: ReadS [TrackDestinations]
readsPrec :: Int -> ReadS TrackDestinations
$creadsPrec :: Int -> ReadS TrackDestinations
Read)

dest_track_ids :: TrackDestinations -> [TrackId]
dest_track_ids :: TrackDestinations -> [TrackId]
dest_track_ids = \case
    DeriveDestinations [NoteDestination]
dests -> (NoteDestination -> [TrackId]) -> [NoteDestination] -> [TrackId]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap NoteDestination -> [TrackId]
note_dest_track_ids [NoteDestination]
dests
    ScoreDestinations ScoreDestinations
dests -> ((TrackId, (TrackId, EventIndex)) -> TrackId)
-> ScoreDestinations -> [TrackId]
forall a b. (a -> b) -> [a] -> [b]
map ((TrackId, EventIndex) -> TrackId
forall a b. (a, b) -> a
fst ((TrackId, EventIndex) -> TrackId)
-> ((TrackId, (TrackId, EventIndex)) -> (TrackId, EventIndex))
-> (TrackId, (TrackId, EventIndex))
-> TrackId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TrackId, (TrackId, EventIndex)) -> (TrackId, EventIndex)
forall a b. (a, b) -> b
snd) ScoreDestinations
dests

{- | Score derivation creates destination tracks 1:1 with their source tracks,
    so I can key them with their source TrackIds.

    (source_track_id, (destination_track_id, index))

    For 'block_integrated', the source_track_id should point to a track in the
    source block.  For 'block_integrated_tracks' it should point to a track
    within its own block.  The destination_track_id should always point to
    a track in the same block.
-}
type ScoreDestinations = [(TrackId, (TrackId, EventIndex))]

-- | Destinations for a manually-invoked integration.  A single SourceKey
-- can have destinations on multiple tracks within the block.
type ManualDestinations = Map SourceKey [NoteDestination]

-- | Arbitrary text used to identify the source of this integration.  Unlike
-- automatic integrations, which come from another block or track, a manual
-- integration can bring in events from anywhere, so it needs a unique key
-- to identify the source.
type SourceKey = Text

instance Pretty TrackDestinations where
    format :: TrackDestinations -> Doc
format (DeriveDestinations [NoteDestination]
dests) =
        Doc
"DeriveDestinations" Doc -> Doc -> Doc
Pretty.<+> [NoteDestination] -> Doc
forall a. Pretty a => a -> Doc
Pretty.format [NoteDestination]
dests
    format (ScoreDestinations ScoreDestinations
dests) =
        Doc
"ScoreDestinations" Doc -> Doc -> Doc
Pretty.<+> ScoreDestinations -> Doc
forall a. Pretty a => a -> Doc
Pretty.format ScoreDestinations
dests

-- | This holds the 'EventIndex' for one note track, along with its dependent
-- control tracks.
data NoteDestination = NoteDestination {
    -- | The key should uniquely identify this particular destination.  The next
    -- time there is a merge, the source tracks can match by key.  Otherwise,
    -- they just have to blindly zip sources and dests, and can't detect
    -- deletions or moves.
    NoteDestination -> Text
dest_key :: !Text
    -- | (dest_track, index)
    , NoteDestination -> (TrackId, EventIndex)
dest_note :: !(TrackId, EventIndex)
    -- | Map from control name to the track which was created for it.
    , NoteDestination -> Map Text (TrackId, EventIndex)
dest_controls :: !(Map Text (TrackId, EventIndex))
    } deriving (NoteDestination -> NoteDestination -> Bool
(NoteDestination -> NoteDestination -> Bool)
-> (NoteDestination -> NoteDestination -> Bool)
-> Eq NoteDestination
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NoteDestination -> NoteDestination -> Bool
$c/= :: NoteDestination -> NoteDestination -> Bool
== :: NoteDestination -> NoteDestination -> Bool
$c== :: NoteDestination -> NoteDestination -> Bool
Eq, Int -> NoteDestination -> ShowS
[NoteDestination] -> ShowS
NoteDestination -> String
(Int -> NoteDestination -> ShowS)
-> (NoteDestination -> String)
-> ([NoteDestination] -> ShowS)
-> Show NoteDestination
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NoteDestination] -> ShowS
$cshowList :: [NoteDestination] -> ShowS
show :: NoteDestination -> String
$cshow :: NoteDestination -> String
showsPrec :: Int -> NoteDestination -> ShowS
$cshowsPrec :: Int -> NoteDestination -> ShowS
Show, ReadPrec [NoteDestination]
ReadPrec NoteDestination
Int -> ReadS NoteDestination
ReadS [NoteDestination]
(Int -> ReadS NoteDestination)
-> ReadS [NoteDestination]
-> ReadPrec NoteDestination
-> ReadPrec [NoteDestination]
-> Read NoteDestination
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [NoteDestination]
$creadListPrec :: ReadPrec [NoteDestination]
readPrec :: ReadPrec NoteDestination
$creadPrec :: ReadPrec NoteDestination
readList :: ReadS [NoteDestination]
$creadList :: ReadS [NoteDestination]
readsPrec :: Int -> ReadS NoteDestination
$creadsPrec :: Int -> ReadS NoteDestination
Read)

note_dest_track_ids :: NoteDestination -> [TrackId]
note_dest_track_ids :: NoteDestination -> [TrackId]
note_dest_track_ids (NoteDestination Text
_ (TrackId, EventIndex)
note Map Text (TrackId, EventIndex)
controls) =
    (TrackId, EventIndex) -> TrackId
forall a b. (a, b) -> a
fst (TrackId, EventIndex)
note TrackId -> [TrackId] -> [TrackId]
forall a. a -> [a] -> [a]
: ((TrackId, EventIndex) -> TrackId)
-> [(TrackId, EventIndex)] -> [TrackId]
forall a b. (a -> b) -> [a] -> [b]
map (TrackId, EventIndex) -> TrackId
forall a b. (a, b) -> a
fst (Map Text (TrackId, EventIndex) -> [(TrackId, EventIndex)]
forall k a. Map k a -> [a]
Map.elems Map Text (TrackId, EventIndex)
controls)

-- | Create an empty destination for the first integration.
empty_destination :: Text -> TrackId -> [(Text, TrackId)] -> NoteDestination
empty_destination :: Text -> TrackId -> [(Text, TrackId)] -> NoteDestination
empty_destination Text
key TrackId
note [(Text, TrackId)]
controls = NoteDestination
    { dest_key :: Text
dest_key = Text
key
    , dest_note :: (TrackId, EventIndex)
dest_note = (TrackId
note, EventIndex
forall a. Monoid a => a
mempty)
    , dest_controls :: Map Text (TrackId, EventIndex)
dest_controls = [(Text, (TrackId, EventIndex))] -> Map Text (TrackId, EventIndex)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Text, (TrackId, EventIndex))] -> Map Text (TrackId, EventIndex))
-> [(Text, (TrackId, EventIndex))]
-> Map Text (TrackId, EventIndex)
forall a b. (a -> b) -> a -> b
$ ((Text, TrackId) -> (Text, (TrackId, EventIndex)))
-> [(Text, TrackId)] -> [(Text, (TrackId, EventIndex))]
forall a b. (a -> b) -> [a] -> [b]
map ((TrackId -> (TrackId, EventIndex))
-> (Text, TrackId) -> (Text, (TrackId, EventIndex))
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (,EventIndex
forall a. Monoid a => a
mempty)) [(Text, TrackId)]
controls
    }

-- | This is a picture of the integrated events that were used to create an
-- integrated block.  By taking its difference against the current contents of
-- the block I can figure out user edits.
type EventIndex = Map Event.IndexKey Event.Event

short_event_index :: EventIndex -> Text
short_event_index :: EventIndex -> Text
short_event_index EventIndex
index
    | EventIndex -> Bool
forall k a. Map k a -> Bool
Map.null EventIndex
index = Text
"((empty))"
    | Bool
otherwise = Text
"((" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
showt (EventIndex -> Int
forall k a. Map k a -> Int
Map.size EventIndex
index) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TrackTime -> Text
forall a. Pretty a => a -> Text
pretty ((TrackTime, Event) -> TrackTime
forall a b. (a, b) -> a
fst (EventIndex -> (TrackTime, Event)
forall k a. Map k a -> (k, a)
Map.findMin EventIndex
index))
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"--" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TrackTime -> Text
forall a. Pretty a => a -> Text
pretty ((TrackTime, Event) -> TrackTime
forall a b. (a, b) -> a
fst (EventIndex -> (TrackTime, Event)
forall k a. Map k a -> (k, a)
Map.findMax EventIndex
index))
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"))"

instance Pretty NoteDestination where
    format :: NoteDestination -> Doc
format (NoteDestination Text
key (TrackId, EventIndex)
note Map Text (TrackId, EventIndex)
controls) = Doc -> [(Text, Doc)] -> Doc
Pretty.record Doc
"NoteDestination"
        [ (Text
"key", Text -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Text
key)
        , (Text
"note", (TrackId, EventIndex) -> Doc
forall a. Pretty a => a -> Doc
Pretty.format (TrackId, EventIndex)
note)
        , (Text
"controls", Map Text (TrackId, EventIndex) -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Map Text (TrackId, EventIndex)
controls)
        ]

-- | Arrows that should be drawn to indicate integrate relationships.
integrate_skeleton :: Block -> [(Color.Color, [(TrackNum, TrackNum)])]
integrate_skeleton :: Block -> [(Color, [(Int, Int)])]
integrate_skeleton Block
block = ((TrackId, TrackDestinations) -> (Color, [(Int, Int)]))
-> [(TrackId, TrackDestinations)] -> [(Color, [(Int, Int)])]
forall a b. (a -> b) -> [a] -> [b]
map (TrackId, TrackDestinations) -> (Color, [(Int, Int)])
integrate_edges (Block -> [(TrackId, TrackDestinations)]
block_integrated_tracks Block
block)
    where
    integrate_edges :: (TrackId, TrackDestinations) -> (Color, [(Int, Int)])
integrate_edges (TrackId
source_id, ScoreDestinations ScoreDestinations
dests) =
        (,) Color
Config.score_integrate_skeleton ([(Int, Int)] -> (Color, [(Int, Int)]))
-> [(Int, Int)] -> (Color, [(Int, Int)])
forall a b. (a -> b) -> a -> b
$ [(Int, Int)]
-> ((Int, Int) -> [(Int, Int)]) -> Maybe (Int, Int) -> [(Int, Int)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ((Int, Int) -> [(Int, Int)] -> [(Int, Int)]
forall a. a -> [a] -> [a]
:[]) (Maybe (Int, Int) -> [(Int, Int)])
-> Maybe (Int, Int) -> [(Int, Int)]
forall a b. (a -> b) -> a -> b
$ do
            (TrackId
_, (TrackId
dest_id, EventIndex
_)) <- ScoreDestinations -> Maybe (TrackId, (TrackId, EventIndex))
forall a. [a] -> Maybe a
Seq.head ScoreDestinations
dests
            Int
dest <- TrackId -> Maybe Int
tracknum_of TrackId
dest_id
            Int
source <- TrackId -> Maybe Int
tracknum_of TrackId
source_id
            (Int, Int) -> Maybe (Int, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
source, Int
dest)
    integrate_edges (TrackId
source_id, DeriveDestinations [NoteDestination]
dests) =
        (Color
Config.integrate_skeleton, TrackId -> [NoteDestination] -> [(Int, Int)]
edges_of TrackId
source_id [NoteDestination]
dests)
    edges_of :: TrackId -> [NoteDestination] -> [(Int, Int)]
edges_of TrackId
source_id [NoteDestination]
dests = do
        Int
source <- [Int] -> (Int -> [Int]) -> Maybe Int -> [Int]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[]) (Maybe Int -> [Int]) -> Maybe Int -> [Int]
forall a b. (a -> b) -> a -> b
$ TrackId -> Maybe Int
tracknum_of TrackId
source_id
        Int
dest <- (NoteDestination -> Maybe Int) -> [NoteDestination] -> [Int]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (TrackId -> Maybe Int
tracknum_of (TrackId -> Maybe Int)
-> (NoteDestination -> TrackId) -> NoteDestination -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TrackId, EventIndex) -> TrackId
forall a b. (a, b) -> a
fst ((TrackId, EventIndex) -> TrackId)
-> (NoteDestination -> (TrackId, EventIndex))
-> NoteDestination
-> TrackId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NoteDestination -> (TrackId, EventIndex)
dest_note) [NoteDestination]
dests
        (Int, Int) -> [(Int, Int)]
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
source, Int
dest)
    tracknum_of :: TrackId -> Maybe Int
tracknum_of = (TrackId -> Map TrackId Int -> Maybe Int)
-> Map TrackId Int -> TrackId -> Maybe Int
forall a b c. (a -> b -> c) -> b -> a -> c
flip TrackId -> Map TrackId Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Map TrackId Int
tracknums
    tracknums :: Map TrackId Int
tracknums = [(TrackId, Int)] -> Map TrackId Int
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
        [ (TrackId
track_id, Int
tracknum)
        | (Int
tracknum, Just TrackId
track_id) <- [Int] -> [Maybe TrackId] -> [(Int, Maybe TrackId)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..]
            ((Track -> Maybe TrackId) -> [Track] -> [Maybe TrackId]
forall a b. (a -> b) -> [a] -> [b]
map Track -> Maybe TrackId
track_id (Block -> [Track]
block_tracks Block
block))
        ]

block_tracklike_ids :: Block -> [TracklikeId]
block_tracklike_ids :: Block -> [TracklikeId]
block_tracklike_ids = (Track -> TracklikeId) -> [Track] -> [TracklikeId]
forall a b. (a -> b) -> [a] -> [b]
map Track -> TracklikeId
tracklike_id ([Track] -> [TracklikeId])
-> (Block -> [Track]) -> Block -> [TracklikeId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block -> [Track]
block_tracks

block_track_ids :: Block -> [TrackId]
block_track_ids :: Block -> [TrackId]
block_track_ids = [TracklikeId] -> [TrackId]
track_ids_of ([TracklikeId] -> [TrackId])
-> (Block -> [TracklikeId]) -> Block -> [TrackId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block -> [TracklikeId]
block_tracklike_ids

block_ruler_ids :: Block -> [RulerId]
block_ruler_ids :: Block -> [RulerId]
block_ruler_ids = [TracklikeId] -> [RulerId]
ruler_ids_of ([TracklikeId] -> [RulerId])
-> (Block -> [TracklikeId]) -> Block -> [RulerId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block -> [TracklikeId]
block_tracklike_ids

block :: Config -> Text -> [Track] -> Block
block :: Config -> Text -> [Track] -> Block
block Config
config Text
title [Track]
tracks = Block
    { block_title :: Text
block_title = Text
title
    , block_config :: Config
block_config = Config
config
    , block_tracks :: [Track]
block_tracks = [Track]
tracks
    , block_skeleton :: Skeleton
block_skeleton = Skeleton
Skeleton.empty
    , block_integrated :: Maybe (BlockId, TrackDestinations)
block_integrated = Maybe (BlockId, TrackDestinations)
forall a. Maybe a
Nothing
    , block_integrated_tracks :: [(TrackId, TrackDestinations)]
block_integrated_tracks = []
    , block_integrated_manual :: ManualDestinations
block_integrated_manual = ManualDestinations
forall a. Monoid a => a
mempty
    , block_meta :: Meta
block_meta = Meta
forall k a. Map k a
Map.empty
    }

-- | Per-block configuration.
data Config = Config {
    Config -> Box
config_skel_box :: !Box
    , Config -> Box
config_track_box :: !Box
    , Config -> Box
config_sb_box :: !Box
    , Config -> Skeleton
config_skeleton :: !Skeleton
    } deriving (Config -> Config -> Bool
(Config -> Config -> Bool)
-> (Config -> Config -> Bool) -> Eq Config
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Config -> Config -> Bool
$c/= :: Config -> Config -> Bool
== :: Config -> Config -> Bool
$c== :: Config -> Config -> Bool
Eq, Int -> Config -> ShowS
[Config] -> ShowS
Config -> String
(Int -> Config -> ShowS)
-> (Config -> String) -> ([Config] -> ShowS) -> Show Config
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Config] -> ShowS
$cshowList :: [Config] -> ShowS
show :: Config -> String
$cshow :: Config -> String
showsPrec :: Int -> Config -> ShowS
$cshowsPrec :: Int -> Config -> ShowS
Show, (forall x. Config -> Rep Config x)
-> (forall x. Rep Config x -> Config) -> Generic Config
forall x. Rep Config x -> Config
forall x. Config -> Rep Config x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Config x -> Config
$cfrom :: forall x. Config -> Rep Config x
Generics.Generic)

default_config :: Config
default_config :: Config
default_config = Config
    { config_skel_box :: Box
config_skel_box = (Color, Char) -> Box
box (Color, Char)
Config.bconfig_box
    , config_track_box :: Box
config_track_box = (Color, Char) -> Box
box (Color, Char)
Config.bconfig_box
    , config_sb_box :: Box
config_sb_box = (Color, Char) -> Box
box (Color, Char)
Config.bconfig_box
    , config_skeleton :: Skeleton
config_skeleton = Skeleton
Implicit
    } where box :: (Color, Char) -> Box
box = (Color -> Char -> Box) -> (Color, Char) -> Box
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Color -> Char -> Box
Box

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

-- | One of those colored boxes wedged into the corners of the block window.
data Box = Box { Box -> Color
box_color :: !Color.Color, Box -> Char
box_char :: !Char }
    deriving (Box -> Box -> Bool
(Box -> Box -> Bool) -> (Box -> Box -> Bool) -> Eq Box
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Box -> Box -> Bool
$c/= :: Box -> Box -> Bool
== :: Box -> Box -> Bool
$c== :: Box -> Box -> Bool
Eq, Int -> Box -> ShowS
[Box] -> ShowS
Box -> String
(Int -> Box -> ShowS)
-> (Box -> String) -> ([Box] -> ShowS) -> Show Box
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Box] -> ShowS
$cshowList :: [Box] -> ShowS
show :: Box -> String
$cshow :: Box -> String
showsPrec :: Int -> Box -> ShowS
$cshowsPrec :: Int -> Box -> ShowS
Show, ReadPrec [Box]
ReadPrec Box
Int -> ReadS Box
ReadS [Box]
(Int -> ReadS Box)
-> ReadS [Box] -> ReadPrec Box -> ReadPrec [Box] -> Read Box
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Box]
$creadListPrec :: ReadPrec [Box]
readPrec :: ReadPrec Box
$creadPrec :: ReadPrec Box
readList :: ReadS [Box]
$creadList :: ReadS [Box]
readsPrec :: Int -> ReadS Box
$creadsPrec :: Int -> ReadS Box
Read)

instance Pretty Box where
    pretty :: Box -> Text
pretty (Box Color
color Char
c) =
        Color -> Text
forall a. Pretty a => a -> Text
pretty Color
color Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> if Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ' then Text
"" else Text
" '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Char -> Text
Text.singleton Char
c Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"'"

-- | Like 'Track.Track', this has per-track data, but unlike Track.Track,
-- this is data that can vary per-block.
--
-- This is the higher level track that is visible at the haskell level, as
-- opposed to 'DisplayTrack', which is what is visible in the UI.
data Track = Track {
    Track -> TracklikeId
tracklike_id :: !TracklikeId
    -- | Formerly the width was in the view since each view could have
    -- a different width and this was just the default width, but that turned
    -- out to be too much of a hassle, so now all occurences of a track have
    -- the same width.
    , Track -> Int
track_width :: !Types.Width
    -- | This is a width suggested by fltk that should be enough to show all
    -- the text.  Unlike the other fields in Track, it's derived from the track
    -- contents and is automatically updated by the UI.
    , Track -> Int
track_suggested_width :: !Types.Width
    -- | Track display state flags.
    , Track -> Set TrackFlag
track_flags :: !(Set TrackFlag)
    -- | Other tracks are displayed behind this one.  Useful to merge a pitch
    -- track into its note track.
    , Track -> Set TrackId
track_merged :: !(Set TrackId)
    } 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, ReadPrec [Track]
ReadPrec Track
Int -> ReadS Track
ReadS [Track]
(Int -> ReadS Track)
-> ReadS [Track]
-> ReadPrec Track
-> ReadPrec [Track]
-> Read Track
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Track]
$creadListPrec :: ReadPrec [Track]
readPrec :: ReadPrec Track
$creadPrec :: ReadPrec Track
readList :: ReadS [Track]
$creadList :: ReadS [Track]
readsPrec :: Int -> ReadS Track
$creadsPrec :: Int -> ReadS Track
Read)

track_id :: Track -> Maybe TrackId
track_id :: Track -> Maybe TrackId
track_id = TracklikeId -> Maybe TrackId
track_id_of (TracklikeId -> Maybe TrackId)
-> (Track -> TracklikeId) -> Track -> Maybe TrackId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Track -> TracklikeId
tracklike_id

instance Pretty Track where
    pretty :: Track -> Text
pretty (Track TracklikeId
tid Int
width Int
suggested Set TrackFlag
flags Set TrackId
merged) = TracklikeId -> Text
forall a. Pretty a => a -> Text
pretty TracklikeId
tid Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
Text.unwords
            [Int -> Text
forall a. Pretty a => a -> Text
pretty Int
width, Int -> Text
forall a. Pretty a => a -> Text
pretty Int
suggested, Set TrackFlag -> Text
forall a. Pretty a => a -> Text
pretty Set TrackFlag
flags, Set TrackId -> Text
forall a. Pretty a => a -> Text
pretty Set TrackId
merged]

-- | Construct a 'Track' with defaults.
track :: TracklikeId -> Types.Width -> Track
track :: TracklikeId -> Int -> Track
track TracklikeId
tracklike_id Int
width = Track
    { tracklike_id :: TracklikeId
tracklike_id = TracklikeId
tracklike_id
    , track_width :: Int
track_width = Int
width
    , track_suggested_width :: Int
track_suggested_width = Int
width
    , track_flags :: Set TrackFlag
track_flags = Set TrackFlag
forall a. Monoid a => a
mempty
    , track_merged :: Set TrackId
track_merged = Set TrackId
forall a. Monoid a => a
mempty
    }

modify_id :: (TracklikeId -> TracklikeId) -> Track -> Track
modify_id :: (TracklikeId -> TracklikeId) -> Track -> Track
modify_id TracklikeId -> TracklikeId
f Track
track = Track
track { tracklike_id :: TracklikeId
tracklike_id = TracklikeId -> TracklikeId
f (Track -> TracklikeId
tracklike_id Track
track) }

colored_divider :: Color.Color -> Track
colored_divider :: Color -> Track
colored_divider Color
color = TracklikeId -> Int -> Track
track (Divider -> TracklikeId
DId (Color -> Divider
Divider Color
color)) Int
3

divider :: Track
divider :: Track
divider = Color -> Track
colored_divider (Double -> Double -> Double -> Color
Color.rgb Double
0.8 Double
0.8 Double
0.8)

track_collapsed :: Track -> Bool
track_collapsed :: Track -> Bool
track_collapsed = (TrackFlag
Collapse `Set.member`) (Set TrackFlag -> Bool)
-> (Track -> Set TrackFlag) -> Track -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Track -> Set TrackFlag
track_flags

track_selectable :: Track -> Bool
track_selectable :: Track -> Bool
track_selectable track :: Track
track@(Track { tracklike_id :: Track -> TracklikeId
tracklike_id = TId TrackId
_ RulerId
_}) =
    Bool -> Bool
not (Track -> Bool
track_collapsed Track
track)
track_selectable Track
_ = Bool
False

-- | Don't send a track signal to a track unless it actually wants to draw it.
track_wants_signal :: Set TrackFlag -> Track.Track -> Bool
track_wants_signal :: Set TrackFlag -> Track -> Bool
track_wants_signal Set TrackFlag
flags Track
track =
    RenderConfig -> RenderStyle
Track.render_style (Track -> RenderConfig
Track.track_render Track
track) RenderStyle -> RenderStyle -> Bool
forall a. Eq a => a -> a -> Bool
/= RenderStyle
Track.NoRender
    Bool -> Bool -> Bool
&& TrackFlag
Collapse TrackFlag -> Set TrackFlag -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set TrackFlag
flags

-- | This is the low-level representation of a track, which directly
-- corresponds with what is displayed by the UI.  The DisplayTracks should be
-- derivable from a 'Block' deterministically.
data DisplayTrack = DisplayTrack {
    DisplayTrack -> TracklikeId
dtracklike_id :: !TracklikeId
    , DisplayTrack -> Int
dtrack_width :: !Types.Width
    , DisplayTrack -> Set TrackId
dtrack_merged :: !(Set TrackId)
    , DisplayTrack -> Status
dtrack_status :: !Status
    , DisplayTrack -> Double
dtrack_event_brightness :: !Double
    } deriving (DisplayTrack -> DisplayTrack -> Bool
(DisplayTrack -> DisplayTrack -> Bool)
-> (DisplayTrack -> DisplayTrack -> Bool) -> Eq DisplayTrack
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DisplayTrack -> DisplayTrack -> Bool
$c/= :: DisplayTrack -> DisplayTrack -> Bool
== :: DisplayTrack -> DisplayTrack -> Bool
$c== :: DisplayTrack -> DisplayTrack -> Bool
Eq, Int -> DisplayTrack -> ShowS
[DisplayTrack] -> ShowS
DisplayTrack -> String
(Int -> DisplayTrack -> ShowS)
-> (DisplayTrack -> String)
-> ([DisplayTrack] -> ShowS)
-> Show DisplayTrack
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DisplayTrack] -> ShowS
$cshowList :: [DisplayTrack] -> ShowS
show :: DisplayTrack -> String
$cshow :: DisplayTrack -> String
showsPrec :: Int -> DisplayTrack -> ShowS
$cshowsPrec :: Int -> DisplayTrack -> ShowS
Show, ReadPrec [DisplayTrack]
ReadPrec DisplayTrack
Int -> ReadS DisplayTrack
ReadS [DisplayTrack]
(Int -> ReadS DisplayTrack)
-> ReadS [DisplayTrack]
-> ReadPrec DisplayTrack
-> ReadPrec [DisplayTrack]
-> Read DisplayTrack
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [DisplayTrack]
$creadListPrec :: ReadPrec [DisplayTrack]
readPrec :: ReadPrec DisplayTrack
$creadPrec :: ReadPrec DisplayTrack
readList :: ReadS [DisplayTrack]
$creadList :: ReadS [DisplayTrack]
readsPrec :: Int -> ReadS DisplayTrack
$creadsPrec :: Int -> ReadS DisplayTrack
Read)

instance Pretty DisplayTrack where
    format :: DisplayTrack -> Doc
format (DisplayTrack TracklikeId
tlike_id Int
width Set TrackId
merged Status
status Double
_bright) =
        Doc -> [(Text, Doc)] -> Doc
Pretty.record Doc
"DisplayTrack"
            [ (Text
"tracklike_id", TracklikeId -> Doc
forall a. Pretty a => a -> Doc
Pretty.format TracklikeId
tlike_id)
            , (Text
"width", Int -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Int
width)
            , (Text
"merged", Set TrackId -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Set TrackId
merged)
            , (Text
"status", Status -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Status
status)
            ]

-- | This has a 2 character string to display above the track, and a background
-- color.  TODO change to Char Char
data Status = Status !String !Color.Color
    deriving (Status -> Status -> Bool
(Status -> Status -> Bool)
-> (Status -> Status -> Bool) -> Eq Status
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Status -> Status -> Bool
$c/= :: Status -> Status -> Bool
== :: Status -> Status -> Bool
$c== :: Status -> Status -> Bool
Eq, Int -> Status -> ShowS
[Status] -> ShowS
Status -> String
(Int -> Status -> ShowS)
-> (Status -> String) -> ([Status] -> ShowS) -> Show Status
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Status] -> ShowS
$cshowList :: [Status] -> ShowS
show :: Status -> String
$cshow :: Status -> String
showsPrec :: Int -> Status -> ShowS
$cshowsPrec :: Int -> Status -> ShowS
Show, ReadPrec [Status]
ReadPrec Status
Int -> ReadS Status
ReadS [Status]
(Int -> ReadS Status)
-> ReadS [Status]
-> ReadPrec Status
-> ReadPrec [Status]
-> Read Status
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Status]
$creadListPrec :: ReadPrec [Status]
readPrec :: ReadPrec Status
$creadPrec :: ReadPrec Status
readList :: ReadS [Status]
$creadList :: ReadS [Status]
readsPrec :: Int -> ReadS Status
$creadsPrec :: Int -> ReadS Status
Read)

instance Pretty Status where pretty :: Status -> Text
pretty (Status String
cs Color
color) = (String, Color) -> Text
forall a. Pretty a => a -> Text
pretty (String
cs, Color
color)

empty_status :: Status
empty_status :: Status
empty_status = String -> Color -> Status
Status String
"" Color
Color.black

-- | Most of these only make sense for event tracks.
data TrackFlag =
    -- | Track is collapsed to take up less space.
    Collapse
    -- | UI shows solo indication.  If any tracks are soloed on a block, only
    -- those tracks are played.
    | Solo
    -- | UI shows muted indication, player should filter out events from this
    -- track.
    | Mute
    -- | This is like Mute, except that the track is entirely omitted from
    -- derivation.  Since Mute and Solo work after derivation, they don't
    -- require a rederive but also can't mute a single control track.
    | Disable
    deriving (TrackFlag -> TrackFlag -> Bool
(TrackFlag -> TrackFlag -> Bool)
-> (TrackFlag -> TrackFlag -> Bool) -> Eq TrackFlag
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TrackFlag -> TrackFlag -> Bool
$c/= :: TrackFlag -> TrackFlag -> Bool
== :: TrackFlag -> TrackFlag -> Bool
$c== :: TrackFlag -> TrackFlag -> Bool
Eq, Eq TrackFlag
Eq TrackFlag
-> (TrackFlag -> TrackFlag -> Ordering)
-> (TrackFlag -> TrackFlag -> Bool)
-> (TrackFlag -> TrackFlag -> Bool)
-> (TrackFlag -> TrackFlag -> Bool)
-> (TrackFlag -> TrackFlag -> Bool)
-> (TrackFlag -> TrackFlag -> TrackFlag)
-> (TrackFlag -> TrackFlag -> TrackFlag)
-> Ord TrackFlag
TrackFlag -> TrackFlag -> Bool
TrackFlag -> TrackFlag -> Ordering
TrackFlag -> TrackFlag -> TrackFlag
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: TrackFlag -> TrackFlag -> TrackFlag
$cmin :: TrackFlag -> TrackFlag -> TrackFlag
max :: TrackFlag -> TrackFlag -> TrackFlag
$cmax :: TrackFlag -> TrackFlag -> TrackFlag
>= :: TrackFlag -> TrackFlag -> Bool
$c>= :: TrackFlag -> TrackFlag -> Bool
> :: TrackFlag -> TrackFlag -> Bool
$c> :: TrackFlag -> TrackFlag -> Bool
<= :: TrackFlag -> TrackFlag -> Bool
$c<= :: TrackFlag -> TrackFlag -> Bool
< :: TrackFlag -> TrackFlag -> Bool
$c< :: TrackFlag -> TrackFlag -> Bool
compare :: TrackFlag -> TrackFlag -> Ordering
$ccompare :: TrackFlag -> TrackFlag -> Ordering
Ord, Int -> TrackFlag
TrackFlag -> Int
TrackFlag -> [TrackFlag]
TrackFlag -> TrackFlag
TrackFlag -> TrackFlag -> [TrackFlag]
TrackFlag -> TrackFlag -> TrackFlag -> [TrackFlag]
(TrackFlag -> TrackFlag)
-> (TrackFlag -> TrackFlag)
-> (Int -> TrackFlag)
-> (TrackFlag -> Int)
-> (TrackFlag -> [TrackFlag])
-> (TrackFlag -> TrackFlag -> [TrackFlag])
-> (TrackFlag -> TrackFlag -> [TrackFlag])
-> (TrackFlag -> TrackFlag -> TrackFlag -> [TrackFlag])
-> Enum TrackFlag
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: TrackFlag -> TrackFlag -> TrackFlag -> [TrackFlag]
$cenumFromThenTo :: TrackFlag -> TrackFlag -> TrackFlag -> [TrackFlag]
enumFromTo :: TrackFlag -> TrackFlag -> [TrackFlag]
$cenumFromTo :: TrackFlag -> TrackFlag -> [TrackFlag]
enumFromThen :: TrackFlag -> TrackFlag -> [TrackFlag]
$cenumFromThen :: TrackFlag -> TrackFlag -> [TrackFlag]
enumFrom :: TrackFlag -> [TrackFlag]
$cenumFrom :: TrackFlag -> [TrackFlag]
fromEnum :: TrackFlag -> Int
$cfromEnum :: TrackFlag -> Int
toEnum :: Int -> TrackFlag
$ctoEnum :: Int -> TrackFlag
pred :: TrackFlag -> TrackFlag
$cpred :: TrackFlag -> TrackFlag
succ :: TrackFlag -> TrackFlag
$csucc :: TrackFlag -> TrackFlag
Enum, TrackFlag
TrackFlag -> TrackFlag -> Bounded TrackFlag
forall a. a -> a -> Bounded a
maxBound :: TrackFlag
$cmaxBound :: TrackFlag
minBound :: TrackFlag
$cminBound :: TrackFlag
Bounded, Int -> TrackFlag -> ShowS
[TrackFlag] -> ShowS
TrackFlag -> String
(Int -> TrackFlag -> ShowS)
-> (TrackFlag -> String)
-> ([TrackFlag] -> ShowS)
-> Show TrackFlag
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TrackFlag] -> ShowS
$cshowList :: [TrackFlag] -> ShowS
show :: TrackFlag -> String
$cshow :: TrackFlag -> String
showsPrec :: Int -> TrackFlag -> ShowS
$cshowsPrec :: Int -> TrackFlag -> ShowS
Show, ReadPrec [TrackFlag]
ReadPrec TrackFlag
Int -> ReadS TrackFlag
ReadS [TrackFlag]
(Int -> ReadS TrackFlag)
-> ReadS [TrackFlag]
-> ReadPrec TrackFlag
-> ReadPrec [TrackFlag]
-> Read TrackFlag
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [TrackFlag]
$creadListPrec :: ReadPrec [TrackFlag]
readPrec :: ReadPrec TrackFlag
$creadPrec :: ReadPrec TrackFlag
readList :: ReadS [TrackFlag]
$creadList :: ReadS [TrackFlag]
readsPrec :: Int -> ReadS TrackFlag
$creadsPrec :: Int -> ReadS TrackFlag
Read)

instance Pretty TrackFlag where pretty :: TrackFlag -> Text
pretty = TrackFlag -> Text
forall a. Show a => a -> Text
showt

-- | Convert logical block level tracks to display tracks.
block_display_tracks :: Block -> [DisplayTrack]
block_display_tracks :: Block -> [DisplayTrack]
block_display_tracks = [DisplayTrack] -> [DisplayTrack]
merge_collapsed ([DisplayTrack] -> [DisplayTrack])
-> (Block -> [DisplayTrack]) -> Block -> [DisplayTrack]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Track -> DisplayTrack) -> [Track] -> [DisplayTrack]
forall a b. (a -> b) -> [a] -> [b]
map Track -> DisplayTrack
display_track ([Track] -> [DisplayTrack])
-> (Block -> [Track]) -> Block -> [DisplayTrack]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block -> [Track]
block_tracks

-- | Merge consecutive collapsed tracks.
merge_collapsed :: [DisplayTrack] -> [DisplayTrack]
merge_collapsed :: [DisplayTrack] -> [DisplayTrack]
merge_collapsed = [DisplayTrack] -> [DisplayTrack]
forall a. a -> a
id
-- TODO I tried this and it looks nice but I'd need to also eliminate the
-- tracks from a Block.display_skeleton and Block.display_integrate_skeleton
-- and I'm not sure it's worth it.
-- merge_collapsed = mapMaybe Seq.head
--     . List.groupBy (\a b -> a == collapsed_track && b == collapsed_track)

-- | This is not exported so callers are forced to go through
-- 'block_display_tracks'.
display_track :: Track -> DisplayTrack
display_track :: Track -> DisplayTrack
display_track Track
track
    | Track -> Bool
track_collapsed Track
track = DisplayTrack
collapsed_track
    | Bool
otherwise = DisplayTrack
        { dtracklike_id :: TracklikeId
dtracklike_id = Track -> TracklikeId
tracklike_id Track
track
        , dtrack_width :: Int
dtrack_width = Track -> Int
track_width Track
track
        , dtrack_merged :: Set TrackId
dtrack_merged = Track -> Set TrackId
track_merged Track
track
        , dtrack_status :: Status
dtrack_status = Status
status
        , dtrack_event_brightness :: Double
dtrack_event_brightness = Double
brightness
        }
    where (Status
status, Double
brightness) = Set TrackFlag -> (Status, Double)
flags_to_status (Track -> Set TrackFlag
track_flags Track
track)

-- | Collapsed tracks are replaced with a divider.
collapsed_track :: DisplayTrack
collapsed_track :: DisplayTrack
collapsed_track = DisplayTrack
    { dtracklike_id :: TracklikeId
dtracklike_id = Divider -> TracklikeId
DId (Color -> Divider
Divider Color
Config.abbreviation_color)
    , dtrack_width :: Int
dtrack_width = Int
Config.collapsed_width
    , dtrack_merged :: Set TrackId
dtrack_merged = Set TrackId
forall a. Monoid a => a
mempty
    , dtrack_status :: Status
dtrack_status = Status
empty_status
    , dtrack_event_brightness :: Double
dtrack_event_brightness = Double
1
    }

display_track_width :: Track -> Types.Width
display_track_width :: Track -> Int
display_track_width = DisplayTrack -> Int
dtrack_width (DisplayTrack -> Int) -> (Track -> DisplayTrack) -> Track -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Track -> DisplayTrack
display_track

flags_to_status :: Set TrackFlag -> (Status, Double)
flags_to_status :: Set TrackFlag -> (Status, Double)
flags_to_status Set TrackFlag
flags
    | TrackFlag
Disable TrackFlag -> Set TrackFlag -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set TrackFlag
flags =
        (String -> Color -> Status
Status (TrackFlag -> String
chars TrackFlag
Disable) Color
Config.mute_color, Double
0.7)
    | TrackFlag
Solo TrackFlag -> Set TrackFlag -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set TrackFlag
flags = (String -> Color -> Status
Status (TrackFlag -> String
chars TrackFlag
Solo) Color
Config.solo_color, Double
1)
    | TrackFlag
Mute TrackFlag -> Set TrackFlag -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set TrackFlag
flags = (String -> Color -> Status
Status (TrackFlag -> String
chars TrackFlag
Mute) Color
Config.mute_color, Double
0.85)
    | Bool
otherwise = (Status
empty_status, Double
1)
    where
    chars :: TrackFlag -> String
chars TrackFlag
flag = (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
' ') ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ TrackFlag -> Char
flag_char TrackFlag
flag
        Char -> ShowS
forall a. a -> [a] -> [a]
: (TrackFlag -> Char) -> [TrackFlag] -> String
forall a b. (a -> b) -> [a] -> [b]
map (Char -> Char
Char.toLower (Char -> Char) -> (TrackFlag -> Char) -> TrackFlag -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TrackFlag -> Char
flag_char) (Set TrackFlag -> [TrackFlag]
forall a. Set a -> [a]
Set.toList (TrackFlag -> Set TrackFlag -> Set TrackFlag
forall a. Ord a => a -> Set a -> Set a
Set.delete TrackFlag
flag Set TrackFlag
flags))

flag_char :: TrackFlag -> Char
flag_char :: TrackFlag -> Char
flag_char TrackFlag
status = case TrackFlag
status of
    TrackFlag
Disable -> Char
'D'
    TrackFlag
Solo -> Char
'S'
    TrackFlag
Mute -> Char
'M'
    TrackFlag
Collapse -> Char
' '

data TracklikeId =
    -- | Tracks may have a Ruler overlay
    TId TrackId RulerId
    | RId RulerId
    | DId Divider
    deriving (TracklikeId -> TracklikeId -> Bool
(TracklikeId -> TracklikeId -> Bool)
-> (TracklikeId -> TracklikeId -> Bool) -> Eq TracklikeId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TracklikeId -> TracklikeId -> Bool
$c/= :: TracklikeId -> TracklikeId -> Bool
== :: TracklikeId -> TracklikeId -> Bool
$c== :: TracklikeId -> TracklikeId -> Bool
Eq, Eq TracklikeId
Eq TracklikeId
-> (TracklikeId -> TracklikeId -> Ordering)
-> (TracklikeId -> TracklikeId -> Bool)
-> (TracklikeId -> TracklikeId -> Bool)
-> (TracklikeId -> TracklikeId -> Bool)
-> (TracklikeId -> TracklikeId -> Bool)
-> (TracklikeId -> TracklikeId -> TracklikeId)
-> (TracklikeId -> TracklikeId -> TracklikeId)
-> Ord TracklikeId
TracklikeId -> TracklikeId -> Bool
TracklikeId -> TracklikeId -> Ordering
TracklikeId -> TracklikeId -> TracklikeId
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: TracklikeId -> TracklikeId -> TracklikeId
$cmin :: TracklikeId -> TracklikeId -> TracklikeId
max :: TracklikeId -> TracklikeId -> TracklikeId
$cmax :: TracklikeId -> TracklikeId -> TracklikeId
>= :: TracklikeId -> TracklikeId -> Bool
$c>= :: TracklikeId -> TracklikeId -> Bool
> :: TracklikeId -> TracklikeId -> Bool
$c> :: TracklikeId -> TracklikeId -> Bool
<= :: TracklikeId -> TracklikeId -> Bool
$c<= :: TracklikeId -> TracklikeId -> Bool
< :: TracklikeId -> TracklikeId -> Bool
$c< :: TracklikeId -> TracklikeId -> Bool
compare :: TracklikeId -> TracklikeId -> Ordering
$ccompare :: TracklikeId -> TracklikeId -> Ordering
Ord, Int -> TracklikeId -> ShowS
[TracklikeId] -> ShowS
TracklikeId -> String
(Int -> TracklikeId -> ShowS)
-> (TracklikeId -> String)
-> ([TracklikeId] -> ShowS)
-> Show TracklikeId
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TracklikeId] -> ShowS
$cshowList :: [TracklikeId] -> ShowS
show :: TracklikeId -> String
$cshow :: TracklikeId -> String
showsPrec :: Int -> TracklikeId -> ShowS
$cshowsPrec :: Int -> TracklikeId -> ShowS
Show, ReadPrec [TracklikeId]
ReadPrec TracklikeId
Int -> ReadS TracklikeId
ReadS [TracklikeId]
(Int -> ReadS TracklikeId)
-> ReadS [TracklikeId]
-> ReadPrec TracklikeId
-> ReadPrec [TracklikeId]
-> Read TracklikeId
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [TracklikeId]
$creadListPrec :: ReadPrec [TracklikeId]
readPrec :: ReadPrec TracklikeId
$creadPrec :: ReadPrec TracklikeId
readList :: ReadS [TracklikeId]
$creadList :: ReadS [TracklikeId]
readsPrec :: Int -> ReadS TracklikeId
$creadsPrec :: Int -> ReadS TracklikeId
Read)

instance Pretty TracklikeId where
    pretty :: TracklikeId -> Text
pretty TracklikeId
tlike_id = case TracklikeId
tlike_id of
        TId TrackId
tid RulerId
rid -> TrackId -> Text
forall a. Pretty a => a -> Text
pretty TrackId
tid Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> RulerId -> Text
forall a. Pretty a => a -> Text
pretty RulerId
rid
        RId RulerId
rid -> RulerId -> Text
forall a. Pretty a => a -> Text
pretty RulerId
rid
        DId Divider
divider -> Divider -> Text
forall a. Show a => a -> Text
showt Divider
divider

track_id_of :: TracklikeId -> Maybe TrackId
track_id_of :: TracklikeId -> Maybe TrackId
track_id_of (TId TrackId
tid RulerId
_) = TrackId -> Maybe TrackId
forall a. a -> Maybe a
Just TrackId
tid
track_id_of TracklikeId
_ = Maybe TrackId
forall a. Maybe a
Nothing

track_ids_of :: [TracklikeId] -> [TrackId]
track_ids_of :: [TracklikeId] -> [TrackId]
track_ids_of = (TracklikeId -> Maybe TrackId) -> [TracklikeId] -> [TrackId]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe TracklikeId -> Maybe TrackId
track_id_of

ruler_id_of :: TracklikeId -> Maybe RulerId
ruler_id_of :: TracklikeId -> Maybe RulerId
ruler_id_of (TId TrackId
_ RulerId
rid) = RulerId -> Maybe RulerId
forall a. a -> Maybe a
Just RulerId
rid
ruler_id_of (RId RulerId
rid) = RulerId -> Maybe RulerId
forall a. a -> Maybe a
Just RulerId
rid
ruler_id_of TracklikeId
_ = Maybe RulerId
forall a. Maybe a
Nothing

ruler_ids_of :: [TracklikeId] -> [RulerId]
ruler_ids_of :: [TracklikeId] -> [RulerId]
ruler_ids_of = (TracklikeId -> Maybe RulerId) -> [TracklikeId] -> [RulerId]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe TracklikeId -> Maybe RulerId
ruler_id_of

set_ruler_id :: RulerId -> TracklikeId -> TracklikeId
set_ruler_id :: RulerId -> TracklikeId -> TracklikeId
set_ruler_id RulerId
rid (TId TrackId
tid RulerId
_) = TrackId -> RulerId -> TracklikeId
TId TrackId
tid RulerId
rid
set_ruler_id RulerId
rid (RId RulerId
_) = RulerId -> TracklikeId
RId RulerId
rid
set_ruler_id RulerId
_ TracklikeId
t = TracklikeId
t

data Tracklike =
    T Track.Track Ruler.Ruler
    | R Ruler.Ruler
    | D Divider
    deriving (Int -> Tracklike -> ShowS
[Tracklike] -> ShowS
Tracklike -> String
(Int -> Tracklike -> ShowS)
-> (Tracklike -> String)
-> ([Tracklike] -> ShowS)
-> Show Tracklike
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Tracklike] -> ShowS
$cshowList :: [Tracklike] -> ShowS
show :: Tracklike -> String
$cshow :: Tracklike -> String
showsPrec :: Int -> Tracklike -> ShowS
$cshowsPrec :: Int -> Tracklike -> ShowS
Show)

track_of :: Tracklike -> Maybe Track.Track
track_of :: Tracklike -> Maybe Track
track_of (T Track
track Ruler
_) = Track -> Maybe Track
forall a. a -> Maybe a
Just Track
track
track_of Tracklike
_ = Maybe Track
forall a. Maybe a
Nothing

tracks_of :: [Tracklike] -> [Track.Track]
tracks_of :: [Tracklike] -> [Track]
tracks_of = (Tracklike -> Maybe Track) -> [Tracklike] -> [Track]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Tracklike -> Maybe Track
track_of

ruler_of :: Tracklike -> Maybe Ruler.Ruler
ruler_of :: Tracklike -> Maybe Ruler
ruler_of (T Track
_ Ruler
ruler) = Ruler -> Maybe Ruler
forall a. a -> Maybe a
Just Ruler
ruler
ruler_of (R Ruler
ruler) = Ruler -> Maybe Ruler
forall a. a -> Maybe a
Just Ruler
ruler
ruler_of Tracklike
_ = Maybe Ruler
forall a. Maybe a
Nothing

rulers_of :: [Tracklike] -> [Ruler.Ruler]
rulers_of :: [Tracklike] -> [Ruler]
rulers_of = (Tracklike -> Maybe Ruler) -> [Tracklike] -> [Ruler]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Tracklike -> Maybe Ruler
ruler_of

-- | A divider separating tracks.  Defined here in Block since it's so trivial.
newtype Divider = Divider Color.Color deriving (Divider -> Divider -> Bool
(Divider -> Divider -> Bool)
-> (Divider -> Divider -> Bool) -> Eq Divider
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Divider -> Divider -> Bool
$c/= :: Divider -> Divider -> Bool
== :: Divider -> Divider -> Bool
$c== :: Divider -> Divider -> Bool
Eq, Eq Divider
Eq Divider
-> (Divider -> Divider -> Ordering)
-> (Divider -> Divider -> Bool)
-> (Divider -> Divider -> Bool)
-> (Divider -> Divider -> Bool)
-> (Divider -> Divider -> Bool)
-> (Divider -> Divider -> Divider)
-> (Divider -> Divider -> Divider)
-> Ord Divider
Divider -> Divider -> Bool
Divider -> Divider -> Ordering
Divider -> Divider -> Divider
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Divider -> Divider -> Divider
$cmin :: Divider -> Divider -> Divider
max :: Divider -> Divider -> Divider
$cmax :: Divider -> Divider -> Divider
>= :: Divider -> Divider -> Bool
$c>= :: Divider -> Divider -> Bool
> :: Divider -> Divider -> Bool
$c> :: Divider -> Divider -> Bool
<= :: Divider -> Divider -> Bool
$c<= :: Divider -> Divider -> Bool
< :: Divider -> Divider -> Bool
$c< :: Divider -> Divider -> Bool
compare :: Divider -> Divider -> Ordering
$ccompare :: Divider -> Divider -> Ordering
Ord, Int -> Divider -> ShowS
[Divider] -> ShowS
Divider -> String
(Int -> Divider -> ShowS)
-> (Divider -> String) -> ([Divider] -> ShowS) -> Show Divider
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Divider] -> ShowS
$cshowList :: [Divider] -> ShowS
show :: Divider -> String
$cshow :: Divider -> String
showsPrec :: Int -> Divider -> ShowS
$cshowsPrec :: Int -> Divider -> ShowS
Show, ReadPrec [Divider]
ReadPrec Divider
Int -> ReadS Divider
ReadS [Divider]
(Int -> ReadS Divider)
-> ReadS [Divider]
-> ReadPrec Divider
-> ReadPrec [Divider]
-> Read Divider
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Divider]
$creadListPrec :: ReadPrec [Divider]
readPrec :: ReadPrec Divider
$creadPrec :: ReadPrec Divider
readList :: ReadS [Divider]
$creadList :: ReadS [Divider]
readsPrec :: Int -> ReadS Divider
$creadsPrec :: Int -> ReadS Divider
Read)

-- * block view

-- | A view is a single window on screen.  Views are destroyed when the window
-- is closed.
data View = View {
    -- | view_block should never change.
    View -> BlockId
view_block :: !BlockId
    , View -> Rect
view_rect :: !Rect.Rect
    , View -> Padding
view_padding :: !Padding
    -- | Contents of the status line.  Map (sort_order, name) contents.  This
    -- is formatted with 'show_status' and goes in the bar at the bottom of the
    -- window.
    , View -> Map (Int, Text) Text
view_status :: !(Map (Int, Text) Text)
    , View -> Int
view_track_scroll :: !Types.Width
    , View -> Zoom
view_zoom :: !Zoom.Zoom
    , View -> Map Int Selection
view_selections :: !(Map Sel.Num Sel.Selection)
    } 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, Eq View
Eq View
-> (View -> View -> Ordering)
-> (View -> View -> Bool)
-> (View -> View -> Bool)
-> (View -> View -> Bool)
-> (View -> View -> Bool)
-> (View -> View -> View)
-> (View -> View -> View)
-> Ord View
View -> View -> Bool
View -> View -> Ordering
View -> View -> View
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: View -> View -> View
$cmin :: View -> View -> View
max :: View -> View -> View
$cmax :: View -> View -> View
>= :: View -> View -> Bool
$c>= :: View -> View -> Bool
> :: View -> View -> Bool
$c> :: View -> View -> Bool
<= :: View -> View -> Bool
$c<= :: View -> View -> Bool
< :: View -> View -> Bool
$c< :: View -> View -> Bool
compare :: View -> View -> Ordering
$ccompare :: View -> View -> Ordering
Ord, 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, ReadPrec [View]
ReadPrec View
Int -> ReadS View
ReadS [View]
(Int -> ReadS View)
-> ReadS [View] -> ReadPrec View -> ReadPrec [View] -> Read View
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [View]
$creadListPrec :: ReadPrec [View]
readPrec :: ReadPrec View
$creadPrec :: ReadPrec View
readList :: ReadS [View]
$creadList :: ReadS [View]
readsPrec :: Int -> ReadS View
$creadsPrec :: Int -> ReadS View
Read)

instance Pretty View where
    format :: View -> Doc
format (View BlockId
block Rect
rect Padding
padding Map (Int, Text) Text
status Int
tscroll Zoom
zoom Map Int Selection
sels) =
        Doc -> [(Text, Doc)] -> Doc
Pretty.record Doc
"View"
            [ (Text
"block", BlockId -> Doc
forall a. Pretty a => a -> Doc
Pretty.format BlockId
block)
            , (Text
"rect", Rect -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Rect
rect)
            , (Text
"padding", Padding -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Padding
padding)
            , (Text
"status", Map (Int, Text) Text -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Map (Int, Text) Text
status)
            , (Text
"scroll/zoom", (Int, Zoom) -> Doc
forall a. Pretty a => a -> Doc
Pretty.format (Int
tscroll, Zoom
zoom))
            , (Text
"selections", Map Int Selection -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Map Int Selection
sels)
            ]

instance DeepSeq.NFData View where
    rnf :: View -> ()
rnf (View BlockId
bid Rect
rect Padding
padding Map (Int, Text) Text
status Int
scroll Zoom
zoom Map Int Selection
selections) =
        BlockId
bid BlockId -> () -> ()
`seq` Rect
rect Rect -> () -> ()
`seq` Padding
padding Padding -> () -> ()
`seq` Map (Int, Text) Text
status Map (Int, Text) Text -> () -> ()
`seq` Int
scroll
        Int -> () -> ()
`seq` Zoom
zoom Zoom -> () -> ()
`seq` Map Int Selection
selections Map Int Selection -> () -> ()
`seq` ()

-- | Construct a View, using default values for most of its fields.
-- Don't construct views using View directly since 'State.create_view'
-- overwrites view_tracks, and maybe more in the future.
view :: Block -> BlockId -> Rect.Rect -> Zoom.Zoom -> View
view :: Block -> BlockId -> Rect -> Zoom -> View
view Block
block BlockId
block_id Rect
rect Zoom
zoom = View
    { view_block :: BlockId
view_block = BlockId
block_id
    , view_rect :: Rect
view_rect = Rect
rect
    -- These will be filled in when the new view emits its initial resize msg,
    -- but it should start off with the defaults.
    , view_padding :: Padding
view_padding = Block -> Padding
default_padding Block
block
    , view_status :: Map (Int, Text) Text
view_status = Map (Int, Text) Text
forall k a. Map k a
Map.empty
    , view_track_scroll :: Int
view_track_scroll = Int
0
    , view_zoom :: Zoom
view_zoom = Zoom
zoom
    , view_selections :: Map Int Selection
view_selections = Map Int Selection
forall k a. Map k a
Map.empty
    }

-- | Pixel width and height of stuff in the view that is not the track area,
-- i.e. scrollbars, skeleton display, block title, etc.
--
-- Only fltk knows the width of all the various widgets, but it's cached
-- here so pure code doesn't have to call to the UI and import BlockC.
-- Only 'UiMsg.UpdateViewResize' should set this, which in turn comes from
-- MsgCollector::msg_resize, which in turn comes from Block::get_padding.
data Padding = Padding {
    Padding -> Int
left :: !Int
    , Padding -> Int
top :: !Int
    , Padding -> Int
bottom :: !Int
    -- Right padding is not necessary, because I can add up track widths.
    } deriving (Padding -> Padding -> Bool
(Padding -> Padding -> Bool)
-> (Padding -> Padding -> Bool) -> Eq Padding
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Padding -> Padding -> Bool
$c/= :: Padding -> Padding -> Bool
== :: Padding -> Padding -> Bool
$c== :: Padding -> Padding -> Bool
Eq, Eq Padding
Eq Padding
-> (Padding -> Padding -> Ordering)
-> (Padding -> Padding -> Bool)
-> (Padding -> Padding -> Bool)
-> (Padding -> Padding -> Bool)
-> (Padding -> Padding -> Bool)
-> (Padding -> Padding -> Padding)
-> (Padding -> Padding -> Padding)
-> Ord Padding
Padding -> Padding -> Bool
Padding -> Padding -> Ordering
Padding -> Padding -> Padding
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Padding -> Padding -> Padding
$cmin :: Padding -> Padding -> Padding
max :: Padding -> Padding -> Padding
$cmax :: Padding -> Padding -> Padding
>= :: Padding -> Padding -> Bool
$c>= :: Padding -> Padding -> Bool
> :: Padding -> Padding -> Bool
$c> :: Padding -> Padding -> Bool
<= :: Padding -> Padding -> Bool
$c<= :: Padding -> Padding -> Bool
< :: Padding -> Padding -> Bool
$c< :: Padding -> Padding -> Bool
compare :: Padding -> Padding -> Ordering
$ccompare :: Padding -> Padding -> Ordering
Ord, Int -> Padding -> ShowS
[Padding] -> ShowS
Padding -> String
(Int -> Padding -> ShowS)
-> (Padding -> String) -> ([Padding] -> ShowS) -> Show Padding
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Padding] -> ShowS
$cshowList :: [Padding] -> ShowS
show :: Padding -> String
$cshow :: Padding -> String
showsPrec :: Int -> Padding -> ShowS
$cshowsPrec :: Int -> Padding -> ShowS
Show, ReadPrec [Padding]
ReadPrec Padding
Int -> ReadS Padding
ReadS [Padding]
(Int -> ReadS Padding)
-> ReadS [Padding]
-> ReadPrec Padding
-> ReadPrec [Padding]
-> Read Padding
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Padding]
$creadListPrec :: ReadPrec [Padding]
readPrec :: ReadPrec Padding
$creadPrec :: ReadPrec Padding
readList :: ReadS [Padding]
$creadList :: ReadS [Padding]
readsPrec :: Int -> ReadS Padding
$creadsPrec :: Int -> ReadS Padding
Read)

instance Pretty Padding where
    pretty :: Padding -> Text
pretty (Padding Int
left Int
top Int
bottom) = (Int, Int, Int) -> Text
forall a. Pretty a => a -> Text
pretty (Int
left, Int
top, Int
bottom)

default_padding :: Block -> Padding
default_padding :: Block -> Padding
default_padding Block
block = Padding
    { left :: Int
left = Int
Config.view_left_padding
    , top :: Int
top = Int
Config.view_top_padding
        Int -> Int -> Int
forall a. Num a => a -> a -> a
+ if Text -> Bool
Text.null (Block -> Text
block_title Block
block) then Int
0 else Int
Config.block_title_height
    , bottom :: Int
bottom = Int
Config.view_bottom_padding
    }

-- | Figure out what color the background of the status line should be.
status_color :: BlockId -> Block -> Maybe BlockId -> Color.Color
status_color :: BlockId -> Block -> Maybe BlockId -> Color
status_color BlockId
block_id Block
block Maybe BlockId
maybe_root_id
    | BlockId -> Maybe BlockId
forall a. a -> Maybe a
Just BlockId
block_id Maybe BlockId -> Maybe BlockId -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe BlockId
maybe_root_id = Color
Config.status_root
    | Just (BlockId
_, TrackDestinations
dests) <- Block -> Maybe (BlockId, TrackDestinations)
block_integrated Block
block = case TrackDestinations
dests of
        DeriveDestinations {} -> Color
Config.status_integrate_destination
        ScoreDestinations {} -> Color
Config.status_score_integrate_destination
    | Bool
otherwise = Color
Config.status_default

show_status :: Map (Int, Text) Text -> Text
show_status :: Map (Int, Text) Text -> Text
show_status = Text -> [Text] -> Text
Text.intercalate Text
" | " ([Text] -> Text)
-> (Map (Int, Text) Text -> [Text]) -> Map (Int, Text) Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (((Int, Text), Text) -> Text) -> [((Int, Text), Text)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ((Int, Text), Text) -> Text
forall a b. (a, b) -> b
snd ([((Int, Text), Text)] -> [Text])
-> (Map (Int, Text) Text -> [((Int, Text), Text)])
-> Map (Int, Text) Text
-> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map (Int, Text) Text -> [((Int, Text), Text)]
forall k a. Map k a -> [(k, a)]
Map.toAscList
    -- I used to display the keys, but they take up too much space, so now
    -- I just use them for sorting.

-- | Return how much track is in view.
visible_time :: View -> TrackTime
visible_time :: View -> TrackTime
visible_time View
view = Zoom -> Int -> TrackTime
Zoom.to_time (View -> Zoom
view_zoom View
view) (View -> Int
view_visible_time View
view)

visible_track :: View -> Types.Width
visible_track :: View -> Int
visible_track = View -> Int
view_visible_track

-- | Get the rect of the track area within the view.  This is used with
-- 'set_track_rect' to set the size of the visible track area, minus the
-- extra GUI bits around it.
track_rect :: View -> Rect.Rect
track_rect :: View -> Rect
track_rect (View { view_rect :: View -> Rect
view_rect = Rect
rect, view_padding :: View -> Padding
view_padding = Padding
padding }) = Rect.Rect
    { x :: Int
x = Rect -> Int
Rect.x Rect
rect Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Padding -> Int
left Padding
padding
    , y :: Int
y = Rect -> Int
Rect.y Rect
rect Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Padding -> Int
top Padding
padding
    , w :: Int
w = Rect -> Int
Rect.w Rect
rect Int -> Int -> Int
forall a. Num a => a -> a -> a
- Padding -> Int
left Padding
padding
    , h :: Int
h = Rect -> Int
Rect.h Rect
rect Int -> Int -> Int
forall a. Num a => a -> a -> a
- Padding -> Int
top Padding
padding Int -> Int -> Int
forall a. Num a => a -> a -> a
- Padding -> Int
bottom Padding
padding
    }

-- | The inverse of 'track_rect'  Use this to set the track area area to
-- a certain size.
set_track_rect :: View -> Rect.Rect -> Rect.Rect
set_track_rect :: View -> Rect -> Rect
set_track_rect (View { view_padding :: View -> Padding
view_padding = Padding
padding }) Rect
rect = Rect.Rect
    { x :: Int
x = Rect -> Int
Rect.x Rect
rect Int -> Int -> Int
forall a. Num a => a -> a -> a
- Padding -> Int
left Padding
padding
    , y :: Int
y = Rect -> Int
Rect.y Rect
rect Int -> Int -> Int
forall a. Num a => a -> a -> a
- Padding -> Int
top Padding
padding
    , w :: Int
w = Rect -> Int
Rect.w Rect
rect Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Padding -> Int
left Padding
padding
    , h :: Int
h = Rect -> Int
Rect.h Rect
rect Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Padding -> Int
top Padding
padding Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Padding -> Int
bottom Padding
padding
    }

view_visible_track, view_visible_time :: View -> Int
view_visible_track :: View -> Int
view_visible_track View
view = Rect -> Int
Rect.w (View -> Rect
view_rect View
view) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Padding -> Int
left (View -> Padding
view_padding View
view)
view_visible_time :: View -> Int
view_visible_time View
view = Rect -> Int
Rect.h (View -> Rect
view_rect View
view) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Padding -> Int
top Padding
padding Int -> Int -> Int
forall a. Num a => a -> a -> a
- Padding -> Int
bottom Padding
padding
    where padding :: Padding
padding = View -> Padding
view_padding View
view

-- | Y coordinate of the given TrackTime.
screen_pixels :: View -> TrackTime -> Int
screen_pixels :: View -> TrackTime -> Int
screen_pixels View
view TrackTime
t =
    Zoom -> TrackTime -> Int
Zoom.to_pixels (View -> Zoom
view_zoom View
view) (TrackTime
t TrackTime -> TrackTime -> TrackTime
forall a. Num a => a -> a -> a
- Zoom -> TrackTime
Zoom.offset (View -> Zoom
view_zoom View
view))
    Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Padding -> Int
top (View -> Padding
view_padding View
view) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Rect -> Int
Rect.y (View -> Rect
view_rect View
view)