-- Copyright 2013 Evan Laforge
-- This program is distributed under the terms of the GNU General Public
-- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt

{-# LANGUAGE DeriveFunctor #-}
{-# OPTIONS_HADDOCK not-home #-}
-- | State.Config and State.Default, in their own module to avoid circular
-- imports with "State.Update".  Everyone else should pretend they're defined
-- in "Ui.State".
module Ui.UiConfig (
    Config(..)
    , empty_config
    , namespace_, meta, root, allocations, lilypond, default_, saved_views
    , ky, tscore
    , allocations_map
    , allocate
    , verify_allocation
    , Allocations(..), unallocations
    , make_allocations
    , midi_allocations
    , modify_allocation
    , Allocation(..)
    , allocation
    , has_im, has_midi, has_sc
    , is_im_allocation, is_midi_allocation
    , play_cache

    , Backend(..), backend_name
    , midi_config
    , Meta(..)
    , empty_meta
    , creation, last_save, notes, midi_performances, lilypond_performances
    , im_performances
    , MidiPerformance, LilypondPerformance, ImPerformance
    , Performance(..)
    , Default(..)
    , tempo
    , SavedViews
) where
import qualified Control.DeepSeq as DeepSeq
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Text as Text
import qualified Data.Time as Time
import qualified Data.Vector as Vector

import qualified GHC.Generics as Generics

import qualified Util.Lens as Lens
import qualified Util.Num as Num
import qualified Util.Pretty as Pretty

import qualified Derive.ScoreT as ScoreT
import qualified Instrument.Common as Common
import qualified Instrument.Inst as Inst
import qualified Instrument.InstT as InstT

import qualified Midi.Midi as Midi
import qualified Perform.Lilypond.Types as Lilypond
import qualified Perform.Midi.Patch as Patch
import qualified Perform.Signal as Signal

import qualified Synth.Shared.Note as Shared.Note
import qualified Ui.Block as Block
import qualified Ui.Id as Id

import           Global
import           Types


-- | Miscellaneous config data.
data Config = Config {
    -- | The default namespace is used for automatically created IDs, so each
    -- project can import other projects without clashes.
    Config -> Namespace
config_namespace :: !Id.Namespace
    , Config -> Meta
config_meta :: !Meta
    -- | Derivation can start from any block, but it's useful to know which
    -- block represents the entire piece.  This way, given a position on some
    -- block I can determine where in the piece it lies, if anywhere.  This is
    -- useful for playing a block in proper context, or communicating with
    -- a program with a more absolute notion of time, like a DAW.
    , Config -> Maybe BlockId
config_root :: !(Maybe BlockId)

    -- | Instrument allocations.
    , Config -> Allocations
config_allocations :: !Allocations
        -- TODO I'm not a big fan of this name, since it's generic and not
        -- obviously related to instruments.  However the previous name,
        -- 'aliases', was too and I somehow lived through that.  I tried
        -- 'instruments', but it seemed too easy to confuse with
        -- 'ScoreT.Instrument'.
    , Config -> Config
config_lilypond :: !Lilypond.Config
    , Config -> Default
config_default :: !Default
    , Config -> SavedViews
config_saved_views :: !SavedViews
    -- | Locally defined code in the ky language, as parsed by
    -- 'Derive.Parse.parse_ky'.  If the ky defines a note transformer called
    -- @GLOBAL@, it will be implicitly wrapped around every derivation.
    , Config -> Text
config_ky :: !Text
    , Config -> Text
config_tscore :: !Text
    } 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)

empty_config :: Config
empty_config :: Config
empty_config = Config
    { config_namespace :: Namespace
config_namespace = Text -> Namespace
Id.namespace Text
"untitled"
    , config_meta :: Meta
config_meta = Meta
empty_meta
    , config_root :: Maybe BlockId
config_root = Maybe BlockId
forall a. Maybe a
Nothing
    , config_allocations :: Allocations
config_allocations = Allocations
forall a. Monoid a => a
mempty
    , config_lilypond :: Config
config_lilypond = Config
Lilypond.default_config
    , config_default :: Default
config_default = Default
empty_default
    , config_saved_views :: SavedViews
config_saved_views = SavedViews
forall a. Monoid a => a
mempty
    , config_ky :: Text
config_ky = Text
""
    , config_tscore :: Text
config_tscore = Text
""
    }

-- Ui.State already has a function called 'namespace'.
namespace_ :: Config :-> Namespace
namespace_ = (Config -> Namespace)
-> ((Namespace -> Namespace) -> Config -> Config)
-> Config :-> Namespace
forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens Config -> Namespace
config_namespace
    (\Namespace -> Namespace
f Config
r -> Config
r { config_namespace :: Namespace
config_namespace = Namespace -> Namespace
f (Config -> Namespace
config_namespace Config
r) })
meta :: Config :-> Meta
meta = (Config -> Meta)
-> ((Meta -> Meta) -> Config -> Config) -> Config :-> Meta
forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens Config -> Meta
config_meta
    (\Meta -> Meta
f Config
r -> Config
r { config_meta :: Meta
config_meta = Meta -> Meta
f (Config -> Meta
config_meta Config
r) })
root :: Config :-> Maybe BlockId
root = (Config -> Maybe BlockId)
-> ((Maybe BlockId -> Maybe BlockId) -> Config -> Config)
-> Config :-> Maybe BlockId
forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens Config -> Maybe BlockId
config_root
    (\Maybe BlockId -> Maybe BlockId
f Config
r -> Config
r { config_root :: Maybe BlockId
config_root = Maybe BlockId -> Maybe BlockId
f (Config -> Maybe BlockId
config_root Config
r) })
allocations :: Config :-> Allocations
allocations = (Config -> Allocations)
-> ((Allocations -> Allocations) -> Config -> Config)
-> Config :-> Allocations
forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens Config -> Allocations
config_allocations
    (\Allocations -> Allocations
f Config
r -> Config
r { config_allocations :: Allocations
config_allocations = Allocations -> Allocations
f (Config -> Allocations
config_allocations Config
r) })
lilypond :: Config :-> Config
lilypond = (Config -> Config)
-> ((Config -> Config) -> Config -> Config) -> Config :-> Config
forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens Config -> Config
config_lilypond
    (\Config -> Config
f Config
r -> Config
r { config_lilypond :: Config
config_lilypond = Config -> Config
f (Config -> Config
config_lilypond Config
r) })
default_ :: Config :-> Default
default_ = (Config -> Default)
-> ((Default -> Default) -> Config -> Config) -> Config :-> Default
forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens Config -> Default
config_default
    (\Default -> Default
f Config
r -> Config
r { config_default :: Default
config_default = Default -> Default
f (Config -> Default
config_default Config
r) })
saved_views :: Config :-> SavedViews
saved_views = (Config -> SavedViews)
-> ((SavedViews -> SavedViews) -> Config -> Config)
-> Config :-> SavedViews
forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens Config -> SavedViews
config_saved_views
    (\SavedViews -> SavedViews
f Config
r -> Config
r { config_saved_views :: SavedViews
config_saved_views = SavedViews -> SavedViews
f (Config -> SavedViews
config_saved_views Config
r) })
ky :: Config :-> Text
ky = (Config -> Text)
-> ((Text -> Text) -> Config -> Config) -> Config :-> Text
forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens Config -> Text
config_ky
    (\Text -> Text
f Config
r -> Config
r { config_ky :: Text
config_ky = Text -> Text
f (Config -> Text
config_ky Config
r) })
tscore :: Config :-> Text
tscore = (Config -> Text)
-> ((Text -> Text) -> Config -> Config) -> Config :-> Text
forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens Config -> Text
config_tscore
    (\Text -> Text
f Config
r -> Config
r { config_tscore :: Text
config_tscore = Text -> Text
f (Config -> Text
config_tscore Config
r) })

-- | Unwrap the newtype for convenience.
allocations_map :: Lens Config (Map ScoreT.Instrument Allocation)
allocations_map :: Lens Config (Map Instrument Allocation)
allocations_map = (Config -> Map Instrument Allocation)
-> ((Map Instrument Allocation -> Map Instrument Allocation)
    -> Config -> Config)
-> Lens Config (Map Instrument Allocation)
forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens (Allocations -> Map Instrument Allocation
open (Allocations -> Map Instrument Allocation)
-> (Config -> Allocations) -> Config -> Map Instrument Allocation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config -> Allocations
config_allocations)
    (\Map Instrument Allocation -> Map Instrument Allocation
f Config
r -> Config
r { config_allocations :: Allocations
config_allocations =
        Map Instrument Allocation -> Allocations
Allocations (Map Instrument Allocation -> Allocations)
-> Map Instrument Allocation -> Allocations
forall a b. (a -> b) -> a -> b
$ Map Instrument Allocation -> Map Instrument Allocation
f (Map Instrument Allocation -> Map Instrument Allocation)
-> Map Instrument Allocation -> Map Instrument Allocation
forall a b. (a -> b) -> a -> b
$ Allocations -> Map Instrument Allocation
open (Allocations -> Map Instrument Allocation)
-> Allocations -> Map Instrument Allocation
forall a b. (a -> b) -> a -> b
$ Config -> Allocations
config_allocations Config
r })
    where open :: Allocations -> Map Instrument Allocation
open (Allocations Map Instrument Allocation
a) = Map Instrument Allocation
a

-- | Insert an allocation into 'config_allocations' while checking it for
-- validity.
--
-- TODO Of course there's no enforcement for this.  I could get rid of the
-- lens, but there is still uncontrolled access through 'State.modify_config'.
-- On the other hand, it might not really matter, and I do use unchecked
-- modification when the backend doesn't change.
allocate :: Inst.Backend -- ^ This should the result of looking up
    -- 'alloc_qualified' in the instrument db.
    -> ScoreT.Instrument -> Allocation -> Allocations
    -> Either Text Allocations
allocate :: Backend
-> Instrument
-> Allocation
-> Allocations
-> Either Text Allocations
allocate Backend
backend Instrument
instrument Allocation
alloc (Allocations Map Instrument Allocation
allocs) =
    Either Text Allocations
-> (Text -> Either Text Allocations)
-> Maybe Text
-> Either Text Allocations
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Allocations -> Either Text Allocations
forall a b. b -> Either a b
Right Allocations
inserted) Text -> Either Text Allocations
forall a b. a -> Either a b
Left (Maybe Text -> Either Text Allocations)
-> Maybe Text -> Either Text Allocations
forall a b. (a -> b) -> a -> b
$
        Allocations -> Backend -> Instrument -> Allocation -> Maybe Text
verify_allocation (Map Instrument Allocation -> Allocations
Allocations Map Instrument Allocation
allocs) Backend
backend Instrument
instrument Allocation
alloc
    where inserted :: Allocations
inserted = Map Instrument Allocation -> Allocations
Allocations (Map Instrument Allocation -> Allocations)
-> Map Instrument Allocation -> Allocations
forall a b. (a -> b) -> a -> b
$ Instrument
-> Allocation
-> Map Instrument Allocation
-> Map Instrument Allocation
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Instrument
instrument Allocation
alloc Map Instrument Allocation
allocs

verify_allocation :: Allocations -> Inst.Backend -> ScoreT.Instrument
    -> Allocation -> Maybe Text
verify_allocation :: Allocations -> Backend -> Instrument -> Allocation -> Maybe Text
verify_allocation Allocations
allocs Backend
backend Instrument
instrument Allocation
alloc =
    (Text -> Text) -> Maybe Text -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text
prefix<>) (Maybe Text -> Maybe Text) -> Maybe Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$
        Backend -> Allocation -> Maybe Text
verify_backends_match Backend
backend Allocation
alloc
        Maybe Text -> Maybe Text -> Maybe Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Allocations -> Allocation -> Instrument -> Maybe Text
verify_no_overlapping_addrs Allocations
allocs Allocation
alloc Instrument
instrument
    where
    prefix :: Text
prefix = Instrument -> Text
forall a. Pretty a => a -> Text
pretty Instrument
instrument Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" from " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Qualified -> Text
forall a. Pretty a => a -> Text
pretty Qualified
qualified Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": "
    qualified :: Qualified
qualified = Allocation -> Qualified
alloc_qualified Allocation
alloc

verify_no_overlapping_addrs :: Allocations -> Allocation
    -> ScoreT.Instrument -> Maybe Text
verify_no_overlapping_addrs :: Allocations -> Allocation -> Instrument -> Maybe Text
verify_no_overlapping_addrs (Allocations Map Instrument Allocation
allocs) Allocation
alloc Instrument
instrument
    | Bool -> Bool
not ([Addr] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Addr]
out_of_range) =
        Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text
"invalid MIDI channel: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Addr] -> Text
forall a. Pretty a => a -> Text
pretty [Addr]
out_of_range
    | [(Addr, Instrument)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Addr, Instrument)]
overlaps = Maybe Text
forall a. Maybe a
Nothing
    | Bool
otherwise = Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text
"instruments with overlapping channel allocations: "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
", "
            [ Addr -> Text
forall a. Pretty a => a -> Text
pretty Addr
addr Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" used by " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Instrument -> Text
forall a. Pretty a => a -> Text
pretty Instrument
inst
            | (Addr
addr, Instrument
inst) <- [(Addr, Instrument)]
overlaps
            ]
    where
    out_of_range :: [Addr]
out_of_range = (Addr -> Bool) -> [Addr] -> [Addr]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Addr -> Bool) -> Addr -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> a -> Bool
Num.inRange Word8
0 Word8
16 (Word8 -> Bool) -> (Addr -> Word8) -> Addr -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Addr -> Word8
forall a b. (a, b) -> b
snd) ([Addr] -> [Addr]) -> [Addr] -> [Addr]
forall a b. (a -> b) -> a -> b
$ Allocation -> [Addr]
addrs_of Allocation
alloc
    overlaps :: [(Addr, Instrument)]
overlaps = (Addr -> Maybe (Addr, Instrument))
-> [Addr] -> [(Addr, Instrument)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Addr -> Maybe (Addr, Instrument)
find (Allocation -> [Addr]
addrs_of Allocation
alloc)
    find :: Addr -> Maybe (Addr, Instrument)
find Addr
addr = (Addr
addr,) (Instrument -> (Addr, Instrument))
-> ((Instrument, Allocation) -> Instrument)
-> (Instrument, Allocation)
-> (Addr, Instrument)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Instrument, Allocation) -> Instrument
forall a b. (a, b) -> a
fst ((Instrument, Allocation) -> (Addr, Instrument))
-> Maybe (Instrument, Allocation) -> Maybe (Addr, Instrument)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        ((Instrument, Allocation) -> Bool)
-> [(Instrument, Allocation)] -> Maybe (Instrument, Allocation)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find ((Addr
addr `elem`) ([Addr] -> Bool)
-> ((Instrument, Allocation) -> [Addr])
-> (Instrument, Allocation)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Allocation -> [Addr]
addrs_of (Allocation -> [Addr])
-> ((Instrument, Allocation) -> Allocation)
-> (Instrument, Allocation)
-> [Addr]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Instrument, Allocation) -> Allocation
forall a b. (a, b) -> b
snd)
            (((Instrument, Allocation) -> Bool)
-> [(Instrument, Allocation)] -> [(Instrument, Allocation)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Instrument -> Instrument -> Bool
forall a. Eq a => a -> a -> Bool
/=Instrument
instrument) (Instrument -> Bool)
-> ((Instrument, Allocation) -> Instrument)
-> (Instrument, Allocation)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Instrument, Allocation) -> Instrument
forall a b. (a, b) -> a
fst) (Map Instrument Allocation -> [(Instrument, Allocation)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Instrument Allocation
allocs))
            -- Don't count this instrument as an overlap, since I'll be
            -- replacing it.
    addrs_of :: Allocation -> [Addr]
addrs_of Allocation
alloc = case Allocation -> Backend
alloc_backend Allocation
alloc of
        Midi Config
config -> ((Addr, Maybe Int) -> Addr) -> [(Addr, Maybe Int)] -> [Addr]
forall a b. (a -> b) -> [a] -> [b]
map (Addr, Maybe Int) -> Addr
forall a b. (a, b) -> a
fst (Config -> [(Addr, Maybe Int)]
Patch.config_allocation Config
config)
        Backend
_ -> []

verify_backends_match :: Inst.Backend -> Allocation -> Maybe Text
verify_backends_match :: Backend -> Allocation -> Maybe Text
verify_backends_match Backend
backend Allocation
alloc = case (Allocation -> Backend
alloc_backend Allocation
alloc, Backend
backend) of
    (Midi {}, Inst.Midi {}) -> Maybe Text
forall a. Maybe a
Nothing
    (Backend
Im, Inst.Im {}) -> Maybe Text
forall a. Maybe a
Nothing
    (Backend
Sc, Inst.Sc {}) -> Maybe Text
forall a. Maybe a
Nothing
    (Dummy {}, Inst.Dummy {}) -> Maybe Text
forall a. Maybe a
Nothing
    (Backend, Backend)
_ -> Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text
"allocation type " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Backend -> Text
backend_name (Allocation -> Backend
alloc_backend Allocation
alloc)
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" /= instrument type " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Backend -> Text
Inst.backend_name Backend
backend

newtype Allocations = Allocations (Map ScoreT.Instrument Allocation)
    deriving (Allocations -> Allocations -> Bool
(Allocations -> Allocations -> Bool)
-> (Allocations -> Allocations -> Bool) -> Eq Allocations
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Allocations -> Allocations -> Bool
$c/= :: Allocations -> Allocations -> Bool
== :: Allocations -> Allocations -> Bool
$c== :: Allocations -> Allocations -> Bool
Eq, Int -> Allocations -> ShowS
[Allocations] -> ShowS
Allocations -> String
(Int -> Allocations -> ShowS)
-> (Allocations -> String)
-> ([Allocations] -> ShowS)
-> Show Allocations
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Allocations] -> ShowS
$cshowList :: [Allocations] -> ShowS
show :: Allocations -> String
$cshow :: Allocations -> String
showsPrec :: Int -> Allocations -> ShowS
$cshowsPrec :: Int -> Allocations -> ShowS
Show, [Allocations] -> Doc
Allocations -> Text
Allocations -> Doc
(Allocations -> Text)
-> (Allocations -> Doc)
-> ([Allocations] -> Doc)
-> Pretty Allocations
forall a. (a -> Text) -> (a -> Doc) -> ([a] -> Doc) -> Pretty a
formatList :: [Allocations] -> Doc
$cformatList :: [Allocations] -> Doc
format :: Allocations -> Doc
$cformat :: Allocations -> Doc
pretty :: Allocations -> Text
$cpretty :: Allocations -> Text
Pretty, NonEmpty Allocations -> Allocations
Allocations -> Allocations -> Allocations
(Allocations -> Allocations -> Allocations)
-> (NonEmpty Allocations -> Allocations)
-> (forall b. Integral b => b -> Allocations -> Allocations)
-> Semigroup Allocations
forall b. Integral b => b -> Allocations -> Allocations
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: forall b. Integral b => b -> Allocations -> Allocations
$cstimes :: forall b. Integral b => b -> Allocations -> Allocations
sconcat :: NonEmpty Allocations -> Allocations
$csconcat :: NonEmpty Allocations -> Allocations
<> :: Allocations -> Allocations -> Allocations
$c<> :: Allocations -> Allocations -> Allocations
Semigroup, Semigroup Allocations
Allocations
Semigroup Allocations
-> Allocations
-> (Allocations -> Allocations -> Allocations)
-> ([Allocations] -> Allocations)
-> Monoid Allocations
[Allocations] -> Allocations
Allocations -> Allocations -> Allocations
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [Allocations] -> Allocations
$cmconcat :: [Allocations] -> Allocations
mappend :: Allocations -> Allocations -> Allocations
$cmappend :: Allocations -> Allocations -> Allocations
mempty :: Allocations
$cmempty :: Allocations
Monoid)

unallocations :: Allocations -> Map ScoreT.Instrument Allocation
unallocations :: Allocations -> Map Instrument Allocation
unallocations (Allocations Map Instrument Allocation
m) = Map Instrument Allocation
m

-- | Make Allocations with no verification.  This should probably only be used
-- for tests, allocations from user input should use 'allocate'.
make_allocations :: [(ScoreT.Instrument, Allocation)] -> Allocations
make_allocations :: [(Instrument, Allocation)] -> Allocations
make_allocations = Map Instrument Allocation -> Allocations
Allocations (Map Instrument Allocation -> Allocations)
-> ([(Instrument, Allocation)] -> Map Instrument Allocation)
-> [(Instrument, Allocation)]
-> Allocations
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Instrument, Allocation)] -> Map Instrument Allocation
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList

-- | This is 'make_allocations' specialized for MIDI instruments.  Like
-- 'make_allocations', it also does no verification.
midi_allocations :: [(ScoreT.Instrument, (InstT.Qualified, Patch.Config))]
    -> Allocations
midi_allocations :: [(Instrument, (Qualified, Config))] -> Allocations
midi_allocations [(Instrument, (Qualified, Config))]
allocs = Map Instrument Allocation -> Allocations
Allocations (Map Instrument Allocation -> Allocations)
-> Map Instrument Allocation -> Allocations
forall a b. (a -> b) -> a -> b
$ [(Instrument, Allocation)] -> Map Instrument Allocation
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
    [ (Instrument
inst, Qualified -> Backend -> Allocation
allocation Qualified
qual (Config -> Backend
Midi Config
config))
    | (Instrument
inst, (Qualified
qual, Config
config)) <- [(Instrument, (Qualified, Config))]
allocs
    ]

modify_allocation :: ScoreT.Instrument -> (Allocation -> Either Text Allocation)
    -> Allocations -> Either Text Allocations
modify_allocation :: Instrument
-> (Allocation -> Either Text Allocation)
-> Allocations
-> Either Text Allocations
modify_allocation Instrument
instrument Allocation -> Either Text Allocation
modify (Allocations Map Instrument Allocation
allocs) = do
    Allocation
alloc <- Text -> Maybe Allocation -> Either Text Allocation
forall err a. err -> Maybe a -> Either err a
justErr (Text
"no allocation for " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Instrument -> Text
forall a. Pretty a => a -> Text
pretty Instrument
instrument) (Maybe Allocation -> Either Text Allocation)
-> Maybe Allocation -> Either Text Allocation
forall a b. (a -> b) -> a -> b
$
        Instrument -> Map Instrument Allocation -> Maybe Allocation
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Instrument
instrument Map Instrument Allocation
allocs
    Allocation
new_alloc <- Allocation -> Either Text Allocation
modify Allocation
alloc
    Bool -> Either Text () -> Either Text ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Backend -> Backend -> Bool
same_backend (Allocation -> Backend
alloc_backend Allocation
alloc) (Allocation -> Backend
alloc_backend Allocation
new_alloc)) (Either Text () -> Either Text ())
-> Either Text () -> Either Text ()
forall a b. (a -> b) -> a -> b
$
        Text -> Either Text ()
forall a b. a -> Either a b
Left Text
"modify_allocation changed the backend"
    Allocations -> Either Text Allocations
forall (m :: * -> *) a. Monad m => a -> m a
return (Allocations -> Either Text Allocations)
-> Allocations -> Either Text Allocations
forall a b. (a -> b) -> a -> b
$ Map Instrument Allocation -> Allocations
Allocations (Map Instrument Allocation -> Allocations)
-> Map Instrument Allocation -> Allocations
forall a b. (a -> b) -> a -> b
$ Instrument
-> Allocation
-> Map Instrument Allocation
-> Map Instrument Allocation
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Instrument
instrument Allocation
new_alloc Map Instrument Allocation
allocs

{- | This is the root of the dynamic (per-score) instrument config.  It's
    divided into common and backend-specific configuration.

    How instruments work:

    The terminology is a bit inconsistent, but the intention is:

    'Inst.Synth' - Container for Patches.

    Patch - Statically declared as haskell source, contains backend-specific
    configuration, as well as common config in 'Common.Common'.  They are
    grouped with the unfortunately named 'Inst.Inst', and the backend is
    'Inst.Backend'.  They all have a unique name which is 'InstT.Qualified'
    and looks like "synth/patch-name".

    Allocation - An instantiation of a Patch in a particular score, and
    associates it with an Instrument.  Like Patch, it also has common
    config in 'Common.Config' and backend-specific config in
    'Ui.UiConfig.Backend'.  Backend-specific config may be midi devices and
    channels for midi, and Common.Config can override settings from the Patch's
    'Common.Common'.  E.g. allocate "vln1" to "vsl/solo-violin" on MIDI chan 1.

    Instrument - The is a bit overloaded, but generally should mean
    'ScoreT.Instrument', which is just a string used to look up an Allocation.

    Both the Patch and Allocation have Backends and they should match, but this
    can't be statically ensured because Patch is statically declared in the
    source while Allocation is dynamic data which is saved to and loaded from
    the score files.  'verify_backends_match' will check on allocation and
    'Cmd.Cmd.resolve_instrument' will crash if it notices mismatched backends
    don't match.

    There is an additional Dummy backend.  This is for instruments which are
    more abstract and don't correspond to a single Patch, but they can still
    have Patch level config such as special notation or env vars.  For
    instance, pemade or gangsa can refer to a whole section, and must be
    expanded into specific instruments at the derive level.  You can either
    allocate a Dummy from a Patch with 'Inst.Dummy' backend, or allocate one
    from InstT.dummy, which will resolve to an empty Patch.
-}
data Allocation = Allocation {
    Allocation -> Qualified
alloc_qualified :: !InstT.Qualified
    , Allocation -> Config
alloc_config :: !Common.Config
    , Allocation -> Backend
alloc_backend :: !Backend
    } deriving (Allocation -> Allocation -> Bool
(Allocation -> Allocation -> Bool)
-> (Allocation -> Allocation -> Bool) -> Eq Allocation
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Allocation -> Allocation -> Bool
$c/= :: Allocation -> Allocation -> Bool
== :: Allocation -> Allocation -> Bool
$c== :: Allocation -> Allocation -> Bool
Eq, Int -> Allocation -> ShowS
[Allocation] -> ShowS
Allocation -> String
(Int -> Allocation -> ShowS)
-> (Allocation -> String)
-> ([Allocation] -> ShowS)
-> Show Allocation
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Allocation] -> ShowS
$cshowList :: [Allocation] -> ShowS
show :: Allocation -> String
$cshow :: Allocation -> String
showsPrec :: Int -> Allocation -> ShowS
$cshowsPrec :: Int -> Allocation -> ShowS
Show)

allocation :: InstT.Qualified -> Backend -> Allocation
allocation :: Qualified -> Backend -> Allocation
allocation Qualified
qualified Backend
backend = Allocation
    { alloc_qualified :: Qualified
alloc_qualified = Qualified
qualified
    , alloc_config :: Config
alloc_config = Config
Common.empty_config
    , alloc_backend :: Backend
alloc_backend = Backend
backend
    }

instance Pretty Allocation where
    format :: Allocation -> Doc
format (Allocation Qualified
qualified Config
config Backend
backend) = Doc -> [(Text, Doc)] -> Doc
Pretty.record Doc
"Allocation"
        [ (Text
"qualified", Qualified -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Qualified
qualified)
        , (Text
"config", Config -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Config
config)
        , (Text
"backend", Backend -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Backend
backend)
        ]

has_im :: Allocations -> Bool
has_im :: Allocations -> Bool
has_im = (Allocation -> Bool) -> [Allocation] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Allocation -> Bool
is_im_allocation ([Allocation] -> Bool)
-> (Allocations -> [Allocation]) -> Allocations -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Instrument Allocation -> [Allocation]
forall k a. Map k a -> [a]
Map.elems (Map Instrument Allocation -> [Allocation])
-> (Allocations -> Map Instrument Allocation)
-> Allocations
-> [Allocation]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Allocations -> Map Instrument Allocation
unallocations

has_midi :: Allocations -> Bool
has_midi :: Allocations -> Bool
has_midi = (Allocation -> Bool) -> [Allocation] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Allocation -> Bool
is_midi_allocation
    ([Allocation] -> Bool)
-> (Allocations -> [Allocation]) -> Allocations -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Allocation -> Bool) -> [Allocation] -> [Allocation]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Qualified -> Qualified -> Bool
forall a. Eq a => a -> a -> Bool
/= Qualified
play_cache) (Qualified -> Bool)
-> (Allocation -> Qualified) -> Allocation -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Allocation -> Qualified
alloc_qualified) ([Allocation] -> [Allocation])
-> (Allocations -> [Allocation]) -> Allocations -> [Allocation]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Instrument Allocation -> [Allocation]
forall k a. Map k a -> [a]
Map.elems (Map Instrument Allocation -> [Allocation])
-> (Allocations -> Map Instrument Allocation)
-> Allocations
-> [Allocation]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Allocations -> Map Instrument Allocation
unallocations

has_sc :: Allocations -> Bool
has_sc :: Allocations -> Bool
has_sc = (Allocation -> Bool) -> [Allocation] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Allocation -> Bool
is_sc_allocation ([Allocation] -> Bool)
-> (Allocations -> [Allocation]) -> Allocations -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Instrument Allocation -> [Allocation]
forall k a. Map k a -> [a]
Map.elems (Map Instrument Allocation -> [Allocation])
-> (Allocations -> Map Instrument Allocation)
-> Allocations
-> [Allocation]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Allocations -> Map Instrument Allocation
unallocations

play_cache :: InstT.Qualified
play_cache :: Qualified
play_cache = Text -> Text -> Qualified
InstT.Qualified Text
"play-cache" Text
""

is_im_allocation :: Allocation -> Bool
is_im_allocation :: Allocation -> Bool
is_im_allocation Allocation
alloc = case Allocation -> Backend
alloc_backend Allocation
alloc of
    Backend
Im -> Bool
True
    Backend
_ -> Bool
False

is_midi_allocation :: Allocation -> Bool
is_midi_allocation :: Allocation -> Bool
is_midi_allocation Allocation
alloc = case Allocation -> Backend
alloc_backend Allocation
alloc of
    Midi {} -> Bool
True
    Backend
_ -> Bool
False

is_sc_allocation :: Allocation -> Bool
is_sc_allocation :: Allocation -> Bool
is_sc_allocation Allocation
alloc = case Allocation -> Backend
alloc_backend Allocation
alloc of
    Backend
Sc -> Bool
True
    Backend
_ -> Bool
False

-- | Backend-specific config.  This should match the 'Inst.Backend' of the
-- instrument in question, ensured by 'verify_allocation'.
--
-- I can't think of a way to ensure this statically, since the instrument and
-- config are saved in instrument db and score respectively, and only come
-- together when a new score is loaded.
data Backend =
    Midi !Patch.Config
    | Im
    | Sc
    -- | This is for instruments without a backend.  For example a paired
    -- instrument might be written as one instrument, but realized as two
    -- different ones.  It should be resolved to concrete instruments during
    -- derivation, and includes an error msg show if that doesn't happen.
    -- If it's "", inherit the msg from its 'Inst.Dummy', if there is one.
    | Dummy !Text
    deriving (Backend -> Backend -> Bool
(Backend -> Backend -> Bool)
-> (Backend -> Backend -> Bool) -> Eq Backend
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Backend -> Backend -> Bool
$c/= :: Backend -> Backend -> Bool
== :: Backend -> Backend -> Bool
$c== :: Backend -> Backend -> Bool
Eq, Int -> Backend -> ShowS
[Backend] -> ShowS
Backend -> String
(Int -> Backend -> ShowS)
-> (Backend -> String) -> ([Backend] -> ShowS) -> Show Backend
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Backend] -> ShowS
$cshowList :: [Backend] -> ShowS
show :: Backend -> String
$cshow :: Backend -> String
showsPrec :: Int -> Backend -> ShowS
$cshowsPrec :: Int -> Backend -> ShowS
Show)

instance Pretty Backend where
    format :: Backend -> Doc
format = \case
        Midi Config
config -> Config -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Config
config
        Backend
Im -> Doc
"Im"
        Backend
Sc -> Doc
"Sc"
        Dummy Text
msg -> Doc
"Dummy \"" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Text -> Doc
Pretty.text Text
msg Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
"\""

-- | Local 'Backend' version of 'Inst.backend_name', keep them consistent.
backend_name :: Backend -> Text
backend_name :: Backend -> Text
backend_name = \case
    Midi {} -> Text
"midi"
    Backend
Im -> Text
"音"
    Backend
Sc -> Text
"sc"
    Dummy {} -> Text
"dummy"

same_backend :: Backend -> Backend -> Bool
same_backend :: Backend -> Backend -> Bool
same_backend Backend
b1 Backend
b2 = case (Backend
b1, Backend
b2) of
    (Midi {}, Midi {}) -> Bool
True
    (Backend
Im, Backend
Im) -> Bool
True
    (Backend
Sc, Backend
Sc) -> Bool
True
    (Dummy {}, Dummy {}) -> Bool
True
    (Backend, Backend)
_ -> Bool
False

midi_config :: Backend -> Maybe Patch.Config
midi_config :: Backend -> Maybe Config
midi_config (Midi Config
config) = Config -> Maybe Config
forall a. a -> Maybe a
Just Config
config
midi_config Backend
_ = Maybe Config
forall a. Maybe a
Nothing

-- | Extra data that doesn't have any effect on the score.
data Meta = Meta {
    -- | The time the score was created.  This should be reset whenever
    -- the score is started, or copied from a template.
    Meta -> UTCTime
meta_creation :: !Time.UTCTime
    -- | The last time the score was saved.  This is useful to determine which
    -- of several saves is the latest.
    , Meta -> UTCTime
meta_last_save :: !Time.UTCTime
    , Meta -> Text
meta_notes :: !Text
    , Meta -> Map BlockId MidiPerformance
meta_midi_performances :: !(Map BlockId MidiPerformance)
    , Meta -> Map BlockId LilypondPerformance
meta_lilypond_performances :: !(Map BlockId LilypondPerformance)
    , Meta -> Map BlockId ImPerformance
meta_im_performances :: !(Map BlockId ImPerformance)
    } deriving (Meta -> Meta -> Bool
(Meta -> Meta -> Bool) -> (Meta -> Meta -> Bool) -> Eq Meta
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Meta -> Meta -> Bool
$c/= :: Meta -> Meta -> Bool
== :: Meta -> Meta -> Bool
$c== :: Meta -> Meta -> Bool
Eq, Int -> Meta -> ShowS
[Meta] -> ShowS
Meta -> String
(Int -> Meta -> ShowS)
-> (Meta -> String) -> ([Meta] -> ShowS) -> Show Meta
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Meta] -> ShowS
$cshowList :: [Meta] -> ShowS
show :: Meta -> String
$cshow :: Meta -> String
showsPrec :: Int -> Meta -> ShowS
$cshowsPrec :: Int -> Meta -> ShowS
Show, (forall x. Meta -> Rep Meta x)
-> (forall x. Rep Meta x -> Meta) -> Generic Meta
forall x. Rep Meta x -> Meta
forall x. Meta -> Rep Meta x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Meta x -> Meta
$cfrom :: forall x. Meta -> Rep Meta x
Generics.Generic)

empty_meta :: Meta
empty_meta :: Meta
empty_meta = Meta
    { meta_creation :: UTCTime
meta_creation = Day -> DiffTime -> UTCTime
Time.UTCTime (Integer -> Day
Time.ModifiedJulianDay Integer
0) DiffTime
0
    , meta_last_save :: UTCTime
meta_last_save = Day -> DiffTime -> UTCTime
Time.UTCTime (Integer -> Day
Time.ModifiedJulianDay Integer
0) DiffTime
0
    , meta_notes :: Text
meta_notes = Text
""
    , meta_midi_performances :: Map BlockId MidiPerformance
meta_midi_performances = Map BlockId MidiPerformance
forall a. Monoid a => a
mempty
    , meta_lilypond_performances :: Map BlockId LilypondPerformance
meta_lilypond_performances = Map BlockId LilypondPerformance
forall a. Monoid a => a
mempty
    , meta_im_performances :: Map BlockId ImPerformance
meta_im_performances = Map BlockId ImPerformance
forall a. Monoid a => a
mempty
    }

creation :: Meta :-> UTCTime
creation = (Meta -> UTCTime)
-> ((UTCTime -> UTCTime) -> Meta -> Meta) -> Meta :-> UTCTime
forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens Meta -> UTCTime
meta_creation
    (\UTCTime -> UTCTime
f Meta
r -> Meta
r { meta_creation :: UTCTime
meta_creation = UTCTime -> UTCTime
f (Meta -> UTCTime
meta_creation Meta
r) })
last_save :: Meta :-> UTCTime
last_save = (Meta -> UTCTime)
-> ((UTCTime -> UTCTime) -> Meta -> Meta) -> Meta :-> UTCTime
forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens Meta -> UTCTime
meta_last_save
    (\UTCTime -> UTCTime
f Meta
r -> Meta
r { meta_last_save :: UTCTime
meta_last_save = UTCTime -> UTCTime
f (Meta -> UTCTime
meta_last_save Meta
r) })
notes :: Meta :-> Text
notes = (Meta -> Text) -> ((Text -> Text) -> Meta -> Meta) -> Meta :-> Text
forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens Meta -> Text
meta_notes
    (\Text -> Text
f Meta
r -> Meta
r { meta_notes :: Text
meta_notes = Text -> Text
f (Meta -> Text
meta_notes Meta
r) })
midi_performances :: Meta :-> Map BlockId MidiPerformance
midi_performances = (Meta -> Map BlockId MidiPerformance)
-> ((Map BlockId MidiPerformance -> Map BlockId MidiPerformance)
    -> Meta -> Meta)
-> Meta :-> Map BlockId MidiPerformance
forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens Meta -> Map BlockId MidiPerformance
meta_midi_performances
    (\Map BlockId MidiPerformance -> Map BlockId MidiPerformance
f Meta
r -> Meta
r { meta_midi_performances :: Map BlockId MidiPerformance
meta_midi_performances = Map BlockId MidiPerformance -> Map BlockId MidiPerformance
f (Meta -> Map BlockId MidiPerformance
meta_midi_performances Meta
r) })
lilypond_performances :: Meta :-> Map BlockId LilypondPerformance
lilypond_performances = (Meta -> Map BlockId LilypondPerformance)
-> ((Map BlockId LilypondPerformance
     -> Map BlockId LilypondPerformance)
    -> Meta -> Meta)
-> Meta :-> Map BlockId LilypondPerformance
forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens Meta -> Map BlockId LilypondPerformance
meta_lilypond_performances
    (\Map BlockId LilypondPerformance -> Map BlockId LilypondPerformance
f Meta
r -> Meta
r { meta_lilypond_performances :: Map BlockId LilypondPerformance
meta_lilypond_performances =
        Map BlockId LilypondPerformance -> Map BlockId LilypondPerformance
f (Meta -> Map BlockId LilypondPerformance
meta_lilypond_performances Meta
r) })
im_performances :: Meta :-> Map BlockId ImPerformance
im_performances = (Meta -> Map BlockId ImPerformance)
-> ((Map BlockId ImPerformance -> Map BlockId ImPerformance)
    -> Meta -> Meta)
-> Meta :-> Map BlockId ImPerformance
forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens Meta -> Map BlockId ImPerformance
meta_im_performances
    (\Map BlockId ImPerformance -> Map BlockId ImPerformance
f Meta
r -> Meta
r { meta_im_performances :: Map BlockId ImPerformance
meta_im_performances = Map BlockId ImPerformance -> Map BlockId ImPerformance
f (Meta -> Map BlockId ImPerformance
meta_im_performances Meta
r) })

type MidiPerformance = Performance (Vector.Vector Midi.WriteMessage)
type LilypondPerformance = Performance Text
type ImPerformance = Performance (Vector.Vector Shared.Note.Note)

-- | A record of the last successful performance that sounded as expected.  You
-- can compare this with the current performance to see if code changes have
-- messed things up.
--
-- I'm ambivalent about including this in the save file, since it will be saved
-- and loaded all the time when it should rarely change.  But it seems like the
-- only reliable way to keep the score and performance in sync.  Besides, it
-- shouldn't actually be that large, and if it is, the git repo save should
-- only save it when 'Config' changes.  I could also split it into its own
-- file.
data Performance a = Performance {
    forall a. Performance a -> a
perf_events :: !a
    -- | The time this performance was recorded.
    , forall a. Performance a -> UTCTime
perf_creation :: !Time.UTCTime
    -- | Free text, containing the git commit when this performance was taken.
    , forall a. Performance a -> Text
perf_commit :: !Text
    } deriving (Performance a -> Performance a -> Bool
(Performance a -> Performance a -> Bool)
-> (Performance a -> Performance a -> Bool) -> Eq (Performance a)
forall a. Eq a => Performance a -> Performance a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Performance a -> Performance a -> Bool
$c/= :: forall a. Eq a => Performance a -> Performance a -> Bool
== :: Performance a -> Performance a -> Bool
$c== :: forall a. Eq a => Performance a -> Performance a -> Bool
Eq, Int -> Performance a -> ShowS
[Performance a] -> ShowS
Performance a -> String
(Int -> Performance a -> ShowS)
-> (Performance a -> String)
-> ([Performance a] -> ShowS)
-> Show (Performance a)
forall a. Show a => Int -> Performance a -> ShowS
forall a. Show a => [Performance a] -> ShowS
forall a. Show a => Performance a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Performance a] -> ShowS
$cshowList :: forall a. Show a => [Performance a] -> ShowS
show :: Performance a -> String
$cshow :: forall a. Show a => Performance a -> String
showsPrec :: Int -> Performance a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Performance a -> ShowS
Show, (forall a b. (a -> b) -> Performance a -> Performance b)
-> (forall a b. a -> Performance b -> Performance a)
-> Functor Performance
forall a b. a -> Performance b -> Performance a
forall a b. (a -> b) -> Performance a -> Performance b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Performance b -> Performance a
$c<$ :: forall a b. a -> Performance b -> Performance a
fmap :: forall a b. (a -> b) -> Performance a -> Performance b
$cfmap :: forall a b. (a -> b) -> Performance a -> Performance b
Functor)

-- | Initial values for derivation.
--
-- This used to have other fields, but they were replaced by the more general
-- 'ky' and the implicit GLOBAL call.  I haven't removed tempo yet because it's
-- the only way to change the speed for tempo-less blocks, and doesn't affect
-- (or rather, is undone automatically) for integrated blocks.
data Default = Default {
    -- | A toplevel block without a tempo track will get this tempo.
    Default -> Y
default_tempo :: !Signal.Y
    } deriving (Default -> Default -> Bool
(Default -> Default -> Bool)
-> (Default -> Default -> Bool) -> Eq Default
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Default -> Default -> Bool
$c/= :: Default -> Default -> Bool
== :: Default -> Default -> Bool
$c== :: Default -> Default -> Bool
Eq, ReadPrec [Default]
ReadPrec Default
Int -> ReadS Default
ReadS [Default]
(Int -> ReadS Default)
-> ReadS [Default]
-> ReadPrec Default
-> ReadPrec [Default]
-> Read Default
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Default]
$creadListPrec :: ReadPrec [Default]
readPrec :: ReadPrec Default
$creadPrec :: ReadPrec Default
readList :: ReadS [Default]
$creadList :: ReadS [Default]
readsPrec :: Int -> ReadS Default
$creadsPrec :: Int -> ReadS Default
Read, Int -> Default -> ShowS
[Default] -> ShowS
Default -> String
(Int -> Default -> ShowS)
-> (Default -> String) -> ([Default] -> ShowS) -> Show Default
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Default] -> ShowS
$cshowList :: [Default] -> ShowS
show :: Default -> String
$cshow :: Default -> String
showsPrec :: Int -> Default -> ShowS
$cshowsPrec :: Int -> Default -> ShowS
Show)

empty_default :: Default
empty_default :: Default
empty_default = Default { default_tempo :: Y
default_tempo = Y
1 }

tempo :: Default :-> Y
tempo = (Default -> Y) -> ((Y -> Y) -> Default -> Default) -> Default :-> Y
forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens Default -> Y
default_tempo
    (\Y -> Y
f Default
r -> Default
r { default_tempo :: Y
default_tempo = Y -> Y
f (Default -> Y
default_tempo Default
r) })

instance Pretty Config where
    format :: Config -> Doc
format (Config Namespace
namespace Meta
meta Maybe BlockId
root Allocations
allocations Config
lily Default
dflt SavedViews
saved_views Text
ky
            Text
tscore) =
        Doc -> [(Text, Doc)] -> Doc
Pretty.record Doc
"Config"
            [ (Text
"namespace", Namespace -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Namespace
namespace)
            , (Text
"meta", Meta -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Meta
meta)
            , (Text
"root", Maybe BlockId -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Maybe BlockId
root)
            , (Text
"allocations", Allocations -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Allocations
allocations)
            , (Text
"lilypond", Config -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Config
lily)
            , (Text
"default", Default -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Default
dflt)
            , (Text
"saved_views", SavedViews -> Doc
forall a. Pretty a => a -> Doc
Pretty.format SavedViews
saved_views)
            , (Text
"ky", Text -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Text
ky)
            , (Text
"tscore", Text -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Text
tscore)
            ]

instance Pretty Meta where format :: Meta -> Doc
format = Meta -> Doc
forall a. (PrettyG (Rep a), Generic a) => a -> Doc
Pretty.formatG_
instance Pretty MidiPerformance where
    format :: MidiPerformance -> Doc
format = Doc -> (Vector WriteMessage -> Int) -> MidiPerformance -> Doc
forall b a. Pretty b => Doc -> (a -> b) -> Performance a -> Doc
format_performance Doc
"MidiPerformance" Vector WriteMessage -> Int
forall a. Vector a -> Int
Vector.length
instance Pretty LilypondPerformance where
    format :: LilypondPerformance -> Doc
format = Doc -> (Text -> Int) -> LilypondPerformance -> Doc
forall b a. Pretty b => Doc -> (a -> b) -> Performance a -> Doc
format_performance Doc
"LilypondPerformance" (Text -> Text -> Int
Text.count Text
"\n")
instance Pretty ImPerformance where
    format :: ImPerformance -> Doc
format = Doc -> (Vector Note -> Int) -> ImPerformance -> Doc
forall b a. Pretty b => Doc -> (a -> b) -> Performance a -> Doc
format_performance Doc
"ImPerformance" Vector Note -> Int
forall a. Vector a -> Int
Vector.length

format_performance :: Pretty b => Pretty.Doc -> (a -> b) -> Performance a
    -> Pretty.Doc
format_performance :: forall b a. Pretty b => Doc -> (a -> b) -> Performance a -> Doc
format_performance Doc
name a -> b
format_events (Performance a
events UTCTime
creation Text
commit) =
    Doc -> [(Text, Doc)] -> Doc
Pretty.record Doc
name
        [ (Text
"events", b -> Doc
forall a. Pretty a => a -> Doc
Pretty.format (b -> Doc) -> b -> Doc
forall a b. (a -> b) -> a -> b
$ a -> b
format_events a
events)
        , (Text
"creation", Text -> Doc
Pretty.text (Text -> Doc) -> Text -> Doc
forall a b. (a -> b) -> a -> b
$ UTCTime -> Text
forall a. Pretty a => a -> Text
pretty UTCTime
creation)
        , (Text
"commit", Text -> Doc
Pretty.text Text
commit)
        ]

instance Pretty Default where
    format :: Default -> Doc
format (Default Y
tempo) = Doc -> [(Text, Doc)] -> Doc
Pretty.record Doc
"Default"
        [ (Text
"tempo", Y -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Y
tempo) ]

instance DeepSeq.NFData Default where
    rnf :: Default -> ()
rnf (Default Y
tempo) = Y
tempo Y -> () -> ()
`seq` ()

-- | This is a place to save sets of views so you can switch between them.
-- The ViewId is the one with focus.
type SavedViews = Map Text (Map ViewId Block.View, Maybe ViewId)