-- 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
    , convert_backend
    , Meta(..)
    , empty_meta
    , creation, last_save, notes, midi_performances, lilypond_performances
    , im_performances
    , MidiPerformance, LilypondPerformance, ImPerformance
    , Performance(..)
    , make_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 Util.SourceControl as SourceControl

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
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
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 = forall a. Maybe a
Nothing
    , config_allocations :: Allocations
config_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 = 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_ = 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 = 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 = 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 = 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 = 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_ = 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 = 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 = 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 = 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 = forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens (Allocations -> Map Instrument Allocation
open 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 forall a b. (a -> b) -> a -> b
$ Map Instrument Allocation -> Map Instrument Allocation
f forall a b. (a -> b) -> a -> b
$ Allocations -> Map Instrument Allocation
open 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) =
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. b -> Either a b
Right Allocations
inserted) forall a b. a -> Either a b
Left 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 forall a b. (a -> b) -> a -> b
$ 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 =
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text
prefix<>) forall a b. (a -> b) -> a -> b
$
        Backend -> Allocation -> Maybe Text
verify_backends_match Backend
backend Allocation
alloc
        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 = forall a. Pretty a => a -> Text
pretty Instrument
instrument forall a. Semigroup a => a -> a -> a
<> Text
" from " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Qualified
qualified 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 (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Addr]
out_of_range) =
        forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text
"invalid MIDI channel: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty [Addr]
out_of_range
    | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Addr, Instrument)]
overlaps = forall a. Maybe a
Nothing
    | Bool
otherwise = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text
"instruments with overlapping channel allocations: "
        forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
", "
            [ forall a. Pretty a => a -> Text
pretty Addr
addr forall a. Semigroup a => a -> a -> a
<> Text
" used by " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Instrument
inst
            | (Addr
addr, Instrument
inst) <- [(Addr, Instrument)]
overlaps
            ]
    where
    out_of_range :: [Addr]
out_of_range = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => a -> a -> a -> Bool
Num.inRange Word8
0 Word8
16 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall a b. (a -> b) -> a -> b
$ Allocation -> [Addr]
addrs_of Allocation
alloc
    overlaps :: [(Addr, Instrument)]
overlaps = 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,) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find ((Addr
addr `elem`) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Allocation -> [Addr]
addrs_of forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd)
            (forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
/=Instrument
instrument) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) (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 -> forall a b. (a -> b) -> [a] -> [b]
map 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 {}) -> forall a. Maybe a
Nothing
    (Backend
Im, Inst.Im {}) -> forall a. Maybe a
Nothing
    (Backend
Sc, Inst.Sc {}) -> forall a. Maybe a
Nothing
    (Dummy {}, Inst.Dummy {}) -> forall a. Maybe a
Nothing
    (Backend, Backend)
_ -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text
"allocation type " forall a. Semigroup a => a -> a -> a
<> Backend -> Text
backend_name (Allocation -> Backend
alloc_backend Allocation
alloc)
        forall a. Semigroup a => a -> a -> a
<> Text
" /= instrument type " 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
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
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
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
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
[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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall a b. (a -> b) -> a -> b
$ 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 <- forall err a. err -> Maybe a -> Either err a
justErr (Text
"no allocation for " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Instrument
instrument) forall a b. (a -> b) -> a -> b
$
        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
    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)) forall a b. (a -> b) -> a -> b
$
        forall a b. a -> Either a b
Left Text
"modify_allocation changed the backend"
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Map Instrument Allocation -> Allocations
Allocations forall a b. (a -> b) -> a -> b
$ 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
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
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", forall a. Pretty a => a -> Doc
Pretty.format Qualified
qualified)
        , (Text
"config", forall a. Pretty a => a -> Doc
Pretty.format Config
config)
        , (Text
"backend", forall a. Pretty a => a -> Doc
Pretty.format Backend
backend)
        ]

has_im :: Allocations -> Bool
has_im :: Allocations -> Bool
has_im = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Allocation -> Bool
is_im_allocation forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [a]
Map.elems 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 = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Allocation -> Bool
is_midi_allocation
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
/= Qualified
play_cache) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Allocation -> Qualified
alloc_qualified) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [a]
Map.elems 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 = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Allocation -> Bool
is_sc_allocation forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [a]
Map.elems 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
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
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 -> forall a. Pretty a => a -> Doc
Pretty.format Config
config
        Backend
Im -> Doc
"Im"
        Backend
Sc -> Doc
"Sc"
        Dummy Text
msg -> Doc
"Dummy \"" forall a. Semigroup a => a -> a -> a
<> Text -> Doc
Pretty.text Text
msg 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) = forall a. a -> Maybe a
Just Config
config
midi_config Backend
_ = forall a. Maybe a
Nothing

convert_backend :: Inst.Backend -> Backend
convert_backend :: Backend -> Backend
convert_backend = \case
    Inst.Dummy {} -> Text -> Backend
Dummy Text
""
    Inst.Midi {} -> Config -> Backend
Midi forall a b. (a -> b) -> a -> b
$ [(Addr, Maybe Int)] -> Config
Patch.config []
    Inst.Im {} -> Backend
Im
    Inst.Sc {} -> Backend
Sc

-- | 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
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
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. 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 = forall a. Monoid a => a
mempty
    , meta_lilypond_performances :: Map BlockId LilypondPerformance
meta_lilypond_performances = forall a. Monoid a => a
mempty
    , meta_im_performances :: Map BlockId ImPerformance
meta_im_performances = forall a. Monoid a => a
mempty
    }

creation :: Meta :-> UTCTime
creation = 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 = 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 = 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 = 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 = 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 = 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
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
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 -> 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)

make_performance :: a -> IO (Performance a)
make_performance :: forall a. a -> IO (Performance a)
make_performance a
events = do
    UTCTime
time <- IO UTCTime
Time.getCurrentTime
    Entry
commit <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) a. (Stack, MonadIO m) => Text -> m a
errorIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
txt) forall (m :: * -> *) a. Monad m => a -> m a
return forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> IO (Either String Entry)
SourceControl.current String
"."
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Performance
        { perf_events :: a
perf_events = a
events
        , perf_creation :: UTCTime
perf_creation = UTCTime
time
        , perf_commit :: Text
perf_commit = [Text] -> Text
Text.unlines forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a -> b) -> a -> b
$ Entry
commit)
            [ Entry -> Text
SourceControl._hash
            , UTCTime -> Text
SourceControl.showDate forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entry -> UTCTime
SourceControl._date
            , Entry -> Text
SourceControl._summary
            ]
        }

-- | 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
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]
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
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 = 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", forall a. Pretty a => a -> Doc
Pretty.format Namespace
namespace)
            , (Text
"meta", forall a. Pretty a => a -> Doc
Pretty.format Meta
meta)
            , (Text
"root", forall a. Pretty a => a -> Doc
Pretty.format Maybe BlockId
root)
            , (Text
"allocations", forall a. Pretty a => a -> Doc
Pretty.format Allocations
allocations)
            , (Text
"lilypond", forall a. Pretty a => a -> Doc
Pretty.format Config
lily)
            , (Text
"default", forall a. Pretty a => a -> Doc
Pretty.format Default
dflt)
            , (Text
"saved_views", forall a. Pretty a => a -> Doc
Pretty.format SavedViews
saved_views)
            , (Text
"ky", forall a. Pretty a => a -> Doc
Pretty.format Text
ky)
            , (Text
"tscore", forall a. Pretty a => a -> Doc
Pretty.format Text
tscore)
            ]

instance Pretty Meta where format :: Meta -> Doc
format = forall a. (PrettyG (Rep a), Generic a) => a -> Doc
Pretty.formatG_
instance Pretty MidiPerformance where
    format :: MidiPerformance -> Doc
format = forall b a. Pretty b => Doc -> (a -> b) -> Performance a -> Doc
format_performance Doc
"MidiPerformance" forall a. Vector a -> Int
Vector.length
instance Pretty LilypondPerformance where
    format :: LilypondPerformance -> Doc
format = forall b a. Pretty b => Doc -> (a -> b) -> Performance a -> Doc
format_performance Doc
"LilypondPerformance" (Stack => Text -> Text -> Int
Text.count Text
"\n")
instance Pretty ImPerformance where
    format :: ImPerformance -> Doc
format = forall b a. Pretty b => Doc -> (a -> b) -> Performance a -> Doc
format_performance Doc
"ImPerformance" 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", forall a. Pretty a => a -> Doc
Pretty.format forall a b. (a -> b) -> a -> b
$ a -> b
format_events a
events)
        , (Text
"creation", Text -> Doc
Pretty.text forall a b. (a -> b) -> a -> b
$ 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", forall a. Pretty a => a -> Doc
Pretty.format Y
tempo) ]

instance DeepSeq.NFData Default where
    rnf :: Default -> ()
rnf (Default Y
tempo) = Y
tempo seq :: forall a b. a -> b -> b
`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)