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

-- | REPL Cmds dealing with instruments and MIDI config.
module Cmd.Repl.LInst where
import           Prelude hiding (lookup)
import qualified Data.Map as Map
import qualified Data.Text as Text

import qualified Util.Lens as Lens
import qualified Util.Lists as Lists
import qualified Util.Log as Log
import qualified Util.Maps as Maps
import qualified Util.Pretty as Pretty
import qualified Util.Texts as Texts

import qualified Cmd.Cmd as Cmd
import qualified Cmd.Info as Info
import qualified Cmd.Repl.Util as Util
import           Cmd.Repl.Util (Instrument)
import qualified Cmd.Save as Save
import qualified Cmd.Selection as Selection

import qualified Derive.Env as Env
import qualified Derive.EnvKey as EnvKey
import qualified Derive.Parse as Parse
import qualified Derive.ParseTitle as ParseTitle
import qualified Derive.REnv as REnv
import qualified Derive.ScoreT as ScoreT
import qualified Derive.ShowVal as ShowVal
import qualified Derive.Typecheck as Typecheck

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

import qualified Midi.Interface as Interface
import qualified Midi.Midi as Midi
import qualified Perform.Midi.Patch as Patch
import qualified Perform.Pitch as Pitch
import qualified Perform.Sc.Patch as Sc.Patch
import qualified Perform.Sc.Play as Sc.Play
import qualified Perform.Signal as Signal

import qualified Ui.TrackTree as TrackTree
import qualified Ui.Ui as Ui
import qualified Ui.UiConfig as UiConfig

import           Global
import           Types


-- * get

lookup :: Instrument -> Cmd.CmdL (Maybe Cmd.ResolvedInstrument)
lookup :: Text -> CmdL (Maybe ResolvedInstrument)
lookup = forall (m :: * -> *).
M m =>
Instrument -> m (Maybe ResolvedInstrument)
Cmd.lookup_instrument forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Instrument
Util.instrument

lookup_allocation :: Ui.M m => Instrument -> m (Maybe UiConfig.Allocation)
lookup_allocation :: forall (m :: * -> *). M m => Text -> m (Maybe Allocation)
lookup_allocation Text
inst = Instrument -> Lens State (Maybe Allocation)
Ui.allocation (Text -> Instrument
Util.instrument Text
inst) forall (f :: * -> *) a b. Functor f => Lens a b -> f a -> f b
<#> forall (m :: * -> *). M m => m State
Ui.get

get_allocation :: Ui.M m => Instrument -> m UiConfig.Allocation
get_allocation :: forall (m :: * -> *). M m => Text -> m Allocation
get_allocation = forall (m :: * -> *). M m => Instrument -> m Allocation
get_instrument_allocation forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Instrument
Util.instrument

-- | List all allocated instruments.
allocated :: Ui.M m => m [ScoreT.Instrument]
allocated :: forall (m :: * -> *). M m => m [Instrument]
allocated = forall (m :: * -> *) a. M m => (Config -> a) -> m a
Ui.get_config forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [k]
Map.keys forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Lens Config (Map Instrument Allocation)
UiConfig.allocations_map #$)

-- | List all allocated instrument configs all purty-like.
list :: Cmd.M m => m Text
list :: forall (m :: * -> *). M m => m Text
list = forall (m :: * -> *). M m => Text -> m Text
list_like Text
""

list_midi :: Cmd.M m => m [Instrument]
list_midi :: forall (m :: * -> *). M m => m [Text]
list_midi = do
    Map Instrument Allocation
alloc_map <- Lens State Config
Ui.configforall a b c. Lens a b -> Lens b c -> Lens a c
#Lens Config (Map Instrument Allocation)
UiConfig.allocations_map forall (f :: * -> *) a b. Functor f => Lens a b -> f a -> f b
<#> forall (m :: * -> *). M m => m State
Ui.get
    forall (m :: * -> *) a. Monad m => a -> m a
return
        [ Instrument -> Text
ScoreT.instrument_name Instrument
inst
        | (Instrument
inst, Allocation
alloc) <- forall k a. Map k a -> [(k, a)]
Map.toAscList Map Instrument Allocation
alloc_map
        , Allocation -> Bool
UiConfig.is_midi_allocation Allocation
alloc
        ]


-- | Pretty print matching instruments:
--
-- > >pno - pianoteq/ loop1 [1..16]
-- > >syn - sampler/inst 音
list_like :: Cmd.M m => Text -> m Text
list_like :: forall (m :: * -> *). M m => Text -> m Text
list_like Text
pattern = do
    Map Instrument Allocation
alloc_map <- Lens State Config
Ui.configforall a b c. Lens a b -> Lens b c -> Lens a c
#Lens Config (Map Instrument Allocation)
UiConfig.allocations_map forall (f :: * -> *) a b. Functor f => Lens a b -> f a -> f b
<#> forall (m :: * -> *). M m => m State
Ui.get
    InstrumentDb
db <- forall (m :: * -> *) a. M m => (State -> a) -> m a
Cmd.gets forall a b. (a -> b) -> a -> b
$ Config -> InstrumentDb
Cmd.config_instrument_db forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Config
Cmd.state_config
    let ([Instrument]
names, [Allocation]
allocs) = forall a b. [(a, b)] -> ([a], [b])
unzip forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toAscList Map Instrument Allocation
alloc_map
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Text] -> Text
Text.unlines forall a b. (a -> b) -> a -> b
$ Int -> [[Text]] -> [Text]
Texts.columns Int
1
        [ Instrument -> Environ -> Allocation -> [Text]
pretty_alloc Instrument
name (forall {code}. Db code -> Allocation -> Environ
inst_environ InstrumentDb
db Allocation
alloc) Allocation
alloc
        | (Instrument
name, Allocation
alloc) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Instrument]
names [Allocation]
allocs
        , Instrument -> Bool
matches Instrument
name
        ]
    where
    matches :: Instrument -> Bool
matches Instrument
inst = Text
pattern Text -> Text -> Bool
`Text.isInfixOf` Instrument -> Text
ScoreT.instrument_name Instrument
inst
    inst_environ :: Db code -> Allocation -> Environ
inst_environ Db code
db =
        forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty (forall code. Common code -> Environ
Common.common_environ forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall code. Inst code -> Common code
Inst.inst_common)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall code. Qualified -> Db code -> Maybe (Inst code)
Inst.lookup Db code
db forall b c a. (b -> c) -> (a -> b) -> a -> c
. Allocation -> Qualified
UiConfig.alloc_qualified

-- | On the environ, - means it was inherited from the Inst, + is from the
-- Allocation, and * means both had it and the Allocation overrode it.
pretty_alloc :: ScoreT.Instrument -> REnv.Environ
    -> UiConfig.Allocation -> [Text]
pretty_alloc :: Instrument -> Environ -> Allocation -> [Text]
pretty_alloc Instrument
inst Environ
inst_environ Allocation
alloc =
    [ forall a. ShowVal a => a -> Text
ShowVal.show_val Instrument
inst
    , Qualified -> Text
InstT.show_qualified (Allocation -> Qualified
UiConfig.alloc_qualified Allocation
alloc)
    , case Allocation -> Backend
UiConfig.alloc_backend Allocation
alloc of
        UiConfig.Midi Config
config -> [Addr] -> Text
Info.show_addrs (Config -> [Addr]
Patch.config_addrs Config
config)
        Backend
UiConfig.Im -> Text
"音"
        Backend
UiConfig.Sc -> Text
"sc"
        UiConfig.Dummy {} -> Text
"(dummy)"
    -- Put flags in their own column to make them obvious.
    , Config -> Text
show_flags (Allocation -> Config
UiConfig.alloc_config Allocation
alloc)
    , [Text] -> Text
join
        [ Config -> Text
show_common_config (Allocation -> Config
UiConfig.alloc_config Allocation
alloc)
        , case Allocation -> Backend
UiConfig.alloc_backend Allocation
alloc of
            UiConfig.Midi Config
config -> Config -> Text
show_midi_config Config
config
            Backend
_ -> Text
""
        ]
    ]
    where
    show_common_config :: Config -> Text
show_common_config Config
config = [Text] -> Text
join
        [ Environ -> Text
show_environ (Config -> Environ
Common.config_environ Config
config)
        , forall {k} {a}. (Pretty k, Pretty a) => Text -> Map k a -> Text
show_controls Text
"" (Config -> ControlValMap
Common.config_controls Config
config)
        ]
    show_environ :: Environ -> Text
show_environ Environ
environ
        | Environ -> Bool
REnv.null Environ
environ Bool -> Bool -> Bool
&& Environ -> Bool
REnv.null Environ
inst_environ = Text
""
        | Bool
otherwise = forall a. Pretty a => a -> Text
pretty forall a b. (a -> b) -> a -> b
$ [(Doc, Doc)] -> Doc
Pretty.formatMap forall a b. (a -> b) -> a -> b
$
            forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap Text -> Doc
Pretty.text forall a. Pretty a => a -> Doc
Pretty.format forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a} {b}.
(Semigroup a, IsString a) =>
(a, Paired b b) -> (a, b)
fmt) forall a b. (a -> b) -> a -> b
$
            forall k v1 v2.
Ord k =>
Map k v1 -> Map k v2 -> [(k, Paired v1 v2)]
Maps.pairs (Environ -> Map Text Val
REnv.to_map Environ
inst_environ) (Environ -> Map Text Val
REnv.to_map Environ
environ)
        where
        fmt :: (a, Paired b b) -> (a, b)
fmt (a
k, Paired b b
v) = case Paired b b
v of
            Lists.First b
v -> (a
"-" forall a. Semigroup a => a -> a -> a
<> a
k, b
v)
            Lists.Second b
v -> (a
"+" forall a. Semigroup a => a -> a -> a
<> a
k, b
v)
            Lists.Both b
_ b
v -> (a
"*" forall a. Semigroup a => a -> a -> a
<> a
k, b
v)
    show_flags :: Config -> Text
show_flags Config
config
        | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
flags = Text
""
        | Bool
otherwise = Text
"{" forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
", " [Text]
flags forall a. Semigroup a => a -> a -> a
<> Text
"}"
        where
        flags :: [Text]
flags = [Text
"mute" | Config -> Bool
Common.config_mute Config
config]
            forall a. [a] -> [a] -> [a]
++ [Text
"solo" | Config -> Bool
Common.config_solo Config
config]
    show_midi_config :: Config -> Text
show_midi_config = Settings -> Text
pretty_settings forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config -> Settings
Patch.config_settings
    show_controls :: Text -> Map k a -> Text
show_controls Text
msg Map k a
controls
        | forall k a. Map k a -> Bool
Map.null Map k a
controls = Text
""
        | Bool
otherwise = Text
msg forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Map k a
controls
    join :: [Text] -> Text
join = [Text] -> Text
Text.unwords forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
Text.null)

pretty_settings :: Patch.Settings -> Text
pretty_settings :: Settings -> Text
pretty_settings Settings
settings =
    [Text] -> Text
Text.unwords forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
Text.null)
        [ forall {b} {a}.
IsString b =>
(Settings -> Maybe a) -> (a -> b) -> b
if_changed Settings -> Maybe (Set Flag)
Patch.config_flags forall a. Pretty a => a -> Text
pretty
        , forall {b} {a}.
IsString b =>
(Settings -> Maybe a) -> (a -> b) -> b
if_changed Settings -> Maybe Scale
Patch.config_scale forall a b. (a -> b) -> a -> b
$ ((Text
"("<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Semigroup a => a -> a -> a
<>Text
")") forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scale -> Text
show_scale)
        , forall {b} {a}.
IsString b =>
(Settings -> Maybe a) -> (a -> b) -> b
if_changed Settings -> Maybe RealTime
Patch.config_decay forall a b. (a -> b) -> a -> b
$ (Text
"decay="<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Pretty a => a -> Text
pretty
        , forall {b} {a}.
IsString b =>
(Settings -> Maybe a) -> (a -> b) -> b
if_changed Settings -> Maybe PbRange
Patch.config_pitch_bend_range forall a b. (a -> b) -> a -> b
$ (Text
"pb="<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Pretty a => a -> Text
pretty
        , forall {b} {a}.
IsString b =>
(Settings -> Maybe a) -> (a -> b) -> b
if_changed Settings -> Maybe ControlValMap
Patch.config_control_defaults forall a b. (a -> b) -> a -> b
$ (Text
"controls="<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Pretty a => a -> Text
pretty
        ]
    where
    if_changed :: (Settings -> Maybe a) -> (a -> b) -> b
if_changed Settings -> Maybe a
get a -> b
fmt = forall b a. b -> (a -> b) -> Maybe a -> b
maybe b
"" a -> b
fmt (Settings -> Maybe a
get Settings
settings)

show_scale :: Patch.Scale -> Text
show_scale :: Scale -> Text
show_scale Scale
scale = Text
"scale " forall a. Semigroup a => a -> a -> a
<> Scale -> Text
Patch.scale_name Scale
scale forall a. Semigroup a => a -> a -> a
<> Text
" "
    forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt (forall (t :: * -> *) a. Foldable t => t a -> Int
length (Maybe AttributeMap -> Scale -> [(Key, NoteNumber)]
Patch.scale_nns forall a. Maybe a
Nothing Scale
scale)) forall a. Semigroup a => a -> a -> a
<> Text
" keys"

-- | Instrument allocations.
allocations :: Ui.M m => m UiConfig.Allocations
allocations :: forall (m :: * -> *). M m => m Allocations
allocations = Lens State Config
Ui.configforall a b c. Lens a b -> Lens b c -> Lens a c
#Config :-> Allocations
UiConfig.allocations forall (f :: * -> *) a b. Functor f => Lens a b -> f a -> f b
<#> forall (m :: * -> *). M m => m State
Ui.get

-- * add and remove

-- | Midi.Channel is 0-based, but DAWs are 1-based, so so use 1-based for UI.
-- 'list' and ultimately 'Info.show_addrs' also display 1-based.
newtype Channel1 = Channel1 Int
    deriving (Channel1 -> Channel1 -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Channel1 -> Channel1 -> Bool
$c/= :: Channel1 -> Channel1 -> Bool
== :: Channel1 -> Channel1 -> Bool
$c== :: Channel1 -> Channel1 -> Bool
Eq, Int -> Channel1 -> ShowS
[Channel1] -> ShowS
Channel1 -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Channel1] -> ShowS
$cshowList :: [Channel1] -> ShowS
show :: Channel1 -> [Char]
$cshow :: Channel1 -> [Char]
showsPrec :: Int -> Channel1 -> ShowS
$cshowsPrec :: Int -> Channel1 -> ShowS
Show, Integer -> Channel1
Channel1 -> Channel1
Channel1 -> Channel1 -> Channel1
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
fromInteger :: Integer -> Channel1
$cfromInteger :: Integer -> Channel1
signum :: Channel1 -> Channel1
$csignum :: Channel1 -> Channel1
abs :: Channel1 -> Channel1
$cabs :: Channel1 -> Channel1
negate :: Channel1 -> Channel1
$cnegate :: Channel1 -> Channel1
* :: Channel1 -> Channel1 -> Channel1
$c* :: Channel1 -> Channel1 -> Channel1
- :: Channel1 -> Channel1 -> Channel1
$c- :: Channel1 -> Channel1 -> Channel1
+ :: Channel1 -> Channel1 -> Channel1
$c+ :: Channel1 -> Channel1 -> Channel1
Num, Int -> Channel1
Channel1 -> Int
Channel1 -> [Channel1]
Channel1 -> Channel1
Channel1 -> Channel1 -> [Channel1]
Channel1 -> Channel1 -> Channel1 -> [Channel1]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Channel1 -> Channel1 -> Channel1 -> [Channel1]
$cenumFromThenTo :: Channel1 -> Channel1 -> Channel1 -> [Channel1]
enumFromTo :: Channel1 -> Channel1 -> [Channel1]
$cenumFromTo :: Channel1 -> Channel1 -> [Channel1]
enumFromThen :: Channel1 -> Channel1 -> [Channel1]
$cenumFromThen :: Channel1 -> Channel1 -> [Channel1]
enumFrom :: Channel1 -> [Channel1]
$cenumFrom :: Channel1 -> [Channel1]
fromEnum :: Channel1 -> Int
$cfromEnum :: Channel1 -> Int
toEnum :: Int -> Channel1
$ctoEnum :: Int -> Channel1
pred :: Channel1 -> Channel1
$cpred :: Channel1 -> Channel1
succ :: Channel1 -> Channel1
$csucc :: Channel1 -> Channel1
Enum)

to_chan :: Channel1 -> Midi.Channel
to_chan :: Channel1 -> Channel
to_chan (Channel1 Int
c)
    | Int
1 forall a. Ord a => a -> a -> Bool
<= Int
c Bool -> Bool -> Bool
&& Int
c forall a. Ord a => a -> a -> Bool
<= Int
16 = forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
c forall a. Num a => a -> a -> a
- Int
1)
    | Bool
otherwise = forall a. Stack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"MIDI channel out of range: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Int
c

-- | Allocate a new MIDI instrument.  For instance:
--
-- > LInst.add "m" "kontakt/mridangam-g" "loop1" [1]
--
-- This will create an instance of the @kontakt/mridangam@ instrument named
-- @>m@, and assign it to the MIDI WriteDevice @loop1@, with a single MIDI
-- channel 0 allocated.
add :: Instrument -> Qualified -> Text -> [Channel1] -> Cmd.CmdL ()
add :: Text -> Text -> Text -> [Channel1] -> CmdL ()
add Text
inst Text
qualified Text
wdev [Channel1]
chans =
    Text -> Text -> [(Addr, Maybe Int)] -> CmdL ()
add_config Text
inst Text
qualified [((WriteDevice
dev, Channel1 -> Channel
to_chan Channel1
chan), forall a. Maybe a
Nothing) | Channel1
chan <- [Channel1]
chans]
    where dev :: WriteDevice
dev = Text -> WriteDevice
Midi.write_device Text
wdev

add_mpe :: Instrument -> Qualified -> Text -> Cmd.CmdL ()
add_mpe :: Text -> Text -> Text -> CmdL ()
add_mpe Text
inst Text
qualified Text
wdev = Text -> Text -> Text -> [Channel1] -> CmdL ()
add Text
inst Text
qualified Text
wdev [Channel1
2..Channel1
16]

-- | Allocate the given channels for the instrument using its default device.
add_default :: Instrument -> Qualified -> [Channel1] -> Cmd.CmdL ()
add_default :: Text -> Text -> [Channel1] -> CmdL ()
add_default Text
inst Text
qualified [Channel1]
chans = do
    WriteDevice
dev <- Instrument -> CmdL WriteDevice
device_of (Text -> Instrument
Util.instrument Text
inst)
    Text -> Text -> [(Addr, Maybe Int)] -> CmdL ()
add_config Text
inst Text
qualified [((WriteDevice
dev, Channel1 -> Channel
to_chan Channel1
chan), forall a. Maybe a
Nothing) | Channel1
chan <- [Channel1]
chans]

add_config :: Instrument -> Qualified -> [(Patch.Addr, Maybe Patch.Voices)]
    -> Cmd.CmdL ()
add_config :: Text -> Text -> [(Addr, Maybe Int)] -> CmdL ()
add_config Text
inst Text
qualified [(Addr, Maybe Int)]
allocs = do
    Qualified
qualified <- forall (m :: * -> *). M m => Text -> m Qualified
parse_qualified Text
qualified
    forall (m :: * -> *). M m => Instrument -> Allocation -> m ()
allocate (Text -> Instrument
Util.instrument Text
inst) forall a b. (a -> b) -> a -> b
$ Qualified -> Backend -> Allocation
UiConfig.allocation Qualified
qualified forall a b. (a -> b) -> a -> b
$
        Config -> Backend
UiConfig.Midi forall a b. (a -> b) -> a -> b
$ [(Addr, Maybe Int)] -> Config
Patch.config [(Addr, Maybe Int)]
allocs

-- | Allocate a new Im instrument.
add_im :: Instrument -> Qualified -> Cmd.CmdL ()
add_im :: Text -> Text -> CmdL ()
add_im Text
inst Text
qualified = do
    Qualified
qualified <- forall (m :: * -> *). M m => Text -> m Qualified
parse_qualified Text
qualified
    forall (m :: * -> *). M m => Instrument -> Allocation -> m ()
allocate (Text -> Instrument
Util.instrument Text
inst) forall a b. (a -> b) -> a -> b
$
        Qualified -> Backend -> Allocation
UiConfig.allocation Qualified
qualified Backend
UiConfig.Im

add_sc :: Instrument -> Text -> Cmd.CmdT IO ()
add_sc :: Text -> Text -> CmdL ()
add_sc Text
inst Text
patch = forall (m :: * -> *). M m => Instrument -> Allocation -> m ()
allocate (Text -> Instrument
Util.instrument Text
inst) forall a b. (a -> b) -> a -> b
$
    Qualified -> Backend -> Allocation
UiConfig.allocation (Text -> Text -> Qualified
InstT.Qualified Text
"sc" Text
patch) Backend
UiConfig.Sc

-- | Add the play-cache instrument.  This is a dummy instrument used to
-- trigger the play-cache vst.  It's emitted automatically if there are im
-- instruments, but needs a channel allocation.
add_play_cache :: Text -> Channel1 -> Cmd.CmdL ()
add_play_cache :: Text -> Channel1 -> CmdL ()
add_play_cache Text
wdev Channel1
chan =
    forall (m :: * -> *). M m => Instrument -> Allocation -> m ()
allocate (Text -> Instrument
Util.instrument Text
"play-cache") forall a b. (a -> b) -> a -> b
$
        Qualified -> Backend -> Allocation
UiConfig.allocation Qualified
UiConfig.play_cache (Config -> Backend
UiConfig.Midi Config
config)
    where
    config :: Config
config = [(Addr, Maybe Int)] -> Config
Patch.config [((Text -> WriteDevice
Midi.write_device Text
wdev, Channel1 -> Channel
to_chan Channel1
chan), forall a. Maybe a
Nothing)]

-- | Create a dummy instrument.  This is used for instruments which are
-- expected to be converted into other instruments during derivation.  For
-- instance, pasang instruments are stand-ins for polos sangsih pairs.
--
-- The qualified name still has to name a valid patch, with the Dummy backend.
add_dummy :: Instrument -> Instrument -> Cmd.CmdL ()
add_dummy :: Text -> Text -> CmdL ()
add_dummy Text
inst Text
qualified = do
    Qualified
qualified <- forall (m :: * -> *). M m => Text -> m Qualified
parse_qualified Text
qualified
    forall (m :: * -> *). M m => Instrument -> Allocation -> m ()
allocate (Text -> Instrument
Util.instrument Text
inst) forall a b. (a -> b) -> a -> b
$
        Qualified -> Backend -> Allocation
UiConfig.allocation Qualified
qualified (Text -> Backend
UiConfig.Dummy Text
"")

-- | Like 'add_dummy' except it doesn't require a patch.
add_dummy_ :: Instrument -> Text -> Cmd.CmdL ()
add_dummy_ :: Text -> Text -> CmdL ()
add_dummy_ Text
inst Text
msg =
    forall (m :: * -> *). M m => Instrument -> Allocation -> m ()
allocate (Text -> Instrument
Util.instrument Text
inst) forall a b. (a -> b) -> a -> b
$
        Qualified -> Backend -> Allocation
UiConfig.allocation Qualified
InstT.dummy (Text -> Backend
UiConfig.Dummy Text
msg)

-- | All allocations should go through this to verify their validity, unless
-- it's modifying an existing allocation and not changing the Qualified name.
allocate :: Cmd.M m => ScoreT.Instrument -> UiConfig.Allocation -> m ()
allocate :: forall (m :: * -> *). M m => Instrument -> Allocation -> m ()
allocate Instrument
score_inst Allocation
alloc = do
    Inst
inst <- forall (m :: * -> *). M m => Allocation -> m Inst
Cmd.get_alloc_qualified Allocation
alloc
    Allocations
allocs <- Lens State Config
Ui.configforall a b c. Lens a b -> Lens b c -> Lens a c
#Config :-> Allocations
UiConfig.allocations forall (f :: * -> *) a b. Functor f => Lens a b -> f a -> f b
<#> forall (m :: * -> *). M m => m State
Ui.get
    Backend
backend <- case (Allocation -> Backend
UiConfig.alloc_backend Allocation
alloc, forall code. Inst code -> Backend
Inst.inst_backend Inst
inst) of
        (backend :: Backend
backend@(UiConfig.Dummy {}), Inst.Dummy {}) -> forall (m :: * -> *) a. Monad m => a -> m a
return Backend
backend
        -- This is just a convenience, so I can use add_im or something on a
        -- dummy, instead of the proper 'add_dummy'.
        (Backend
backend, Inst.Dummy {}) -> do
            forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.warn forall a b. (a -> b) -> a -> b
$ Text
"switched non-dummy alloc "
                forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty (Allocation -> Qualified
UiConfig.alloc_qualified Allocation
alloc)
                forall a. Semigroup a => a -> a -> a
<> Text
" (" forall a. Semigroup a => a -> a -> a
<> Backend -> Text
UiConfig.backend_name Backend
backend forall a. Semigroup a => a -> a -> a
<> Text
") to dummy"
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text -> Backend
UiConfig.Dummy Text
""
        (Backend
backend, Backend
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return Backend
backend
    Allocations
allocs <- forall (m :: * -> *) err a.
(Stack, M m) =>
(err -> Text) -> Either err a -> m a
Cmd.require_right forall a. a -> a
id forall a b. (a -> b) -> a -> b
$
        Backend
-> Instrument
-> Allocation
-> Allocations
-> Either Text Allocations
UiConfig.allocate (forall code. Inst code -> Backend
Inst.inst_backend Inst
inst) Instrument
score_inst
            (Allocation
alloc { alloc_backend :: Backend
UiConfig.alloc_backend = Backend
backend }) Allocations
allocs
    forall (m :: * -> *). M m => (Config -> Config) -> m ()
Ui.modify_config forall a b. (a -> b) -> a -> b
$ Config :-> Allocations
UiConfig.allocations forall f a. Lens f a -> a -> f -> f
#= Allocations
allocs

-- | Remove an instrument allocation.
remove :: Instrument -> Cmd.CmdL ()
remove :: Text -> CmdL ()
remove = forall (m :: * -> *). M m => Instrument -> m ()
deallocate forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Instrument
Util.instrument

deallocate :: Cmd.M m => ScoreT.Instrument -> m ()
deallocate :: forall (m :: * -> *). M m => Instrument -> m ()
deallocate Instrument
inst = forall (m :: * -> *). M m => (Config -> Config) -> m ()
Ui.modify_config forall a b. (a -> b) -> a -> b
$ Lens Config (Map Instrument Allocation)
UiConfig.allocations_map forall f a. Lens f a -> (a -> a) -> f -> f
%= forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Instrument
inst

-- | Merge the given configs into the existing ones.  This also merges
-- 'Patch.patch_defaults' into 'Patch.config_settings'.  This way functions
-- that create Allocations don't have to find the relevant Patch.
merge :: Cmd.M m => Bool -> UiConfig.Allocations -> m ()
merge :: forall (m :: * -> *). M m => Bool -> Allocations -> m ()
merge Bool
override (UiConfig.Allocations Map Instrument Allocation
alloc_map) = do
    let ([Instrument]
names, [Allocation]
allocs) = forall a b. [(a, b)] -> ([a], [b])
unzip (forall k a. Map k a -> [(k, a)]
Map.toList Map Instrument Allocation
alloc_map)
    [Inst]
insts <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *). M m => Allocation -> m Inst
Cmd.get_alloc_qualified [Allocation]
allocs
    Allocations
existing <- forall (m :: * -> *) a. M m => (Config -> a) -> m a
Ui.get_config (Config :-> Allocations
UiConfig.allocations #$)
    let errors :: [Text]
errors = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall {code}.
Allocations -> (Instrument, Allocation, Inst code) -> Maybe Text
verify Allocations
existing) (forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Instrument]
names [Allocation]
allocs [Inst]
insts)
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
errors) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) a. (Stack, M m) => Text -> m a
Cmd.throw forall a b. (a -> b) -> a -> b
$ Text
"merged allocations: " forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
"\n" [Text]
errors
    let new_allocs :: Allocations
new_allocs = Map Instrument Allocation -> Allocations
UiConfig.Allocations (forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (forall a b. [a] -> [b] -> [(a, b)]
zip [Instrument]
names [Allocation]
allocs))
    forall (m :: * -> *). M m => (Config -> Config) -> m ()
Ui.modify_config forall a b. (a -> b) -> a -> b
$ Config :-> Allocations
UiConfig.allocations
        forall f a. Lens f a -> (a -> a) -> f -> f
%= if Bool
override then (Allocations
new_allocs<>) else (forall a. Semigroup a => a -> a -> a
<>Allocations
new_allocs)
    where
    verify :: Allocations -> (Instrument, Allocation, Inst code) -> Maybe Text
verify Allocations
allocs (Instrument
name, Allocation
alloc, Inst code
inst) =
        Allocations -> Backend -> Instrument -> Allocation -> Maybe Text
UiConfig.verify_allocation Allocations
allocs (forall code. Inst code -> Backend
Inst.inst_backend Inst code
inst) Instrument
name Allocation
alloc

replace :: Cmd.M m => UiConfig.Allocations -> m ()
replace :: forall (m :: * -> *). M m => Allocations -> m ()
replace Allocations
allocs = do
    forall (m :: * -> *). M m => (Config -> Config) -> m ()
Ui.modify_config forall a b. (a -> b) -> a -> b
$ Config :-> Allocations
UiConfig.allocations forall f a. Lens f a -> a -> f -> f
#= forall a. Monoid a => a
mempty
    forall (m :: * -> *). M m => Bool -> Allocations -> m ()
merge Bool
True Allocations
allocs

-- * modify

-- | Point an instrument at a different Qualified.
rename_qualified :: Cmd.M m => Instrument -> Qualified -> m ()
rename_qualified :: forall (m :: * -> *). M m => Text -> Text -> m ()
rename_qualified Text
inst Text
qualified = do
    Qualified
qualified <- forall (m :: * -> *). M m => Text -> m Qualified
parse_qualified Text
qualified
    forall (m :: * -> *). M m => Qualified -> m Inst
Cmd.get_qualified Qualified
qualified
    forall (m :: * -> *).
M m =>
Instrument -> (Allocation -> Allocation) -> m ()
Ui.modify_allocation (Text -> Instrument
Util.instrument Text
inst) forall a b. (a -> b) -> a -> b
$ \Allocation
alloc ->
        Allocation
alloc { alloc_qualified :: Qualified
UiConfig.alloc_qualified = Qualified
qualified }

-- | Rename an instrument.
rename :: Ui.M m => Instrument -> Instrument -> m ()
rename :: forall (m :: * -> *). M m => Text -> Text -> m ()
rename Text
from Text
to = forall (m :: * -> *).
M m =>
Text
-> (Allocation
    -> Map Instrument Allocation -> Map Instrument Allocation)
-> m ()
modify_allocations Text
from forall a b. (a -> b) -> a -> b
$ \Allocation
alloc ->
    forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Text -> Instrument
Util.instrument Text
to) Allocation
alloc
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => k -> Map k a -> Map k a
Map.delete (Text -> Instrument
Util.instrument Text
from)

copy :: Ui.M m => Instrument -> Instrument -> m ()
copy :: forall (m :: * -> *). M m => Text -> Text -> m ()
copy Text
from Text
to = forall (m :: * -> *).
M m =>
Text
-> (Allocation
    -> Map Instrument Allocation -> Map Instrument Allocation)
-> m ()
modify_allocations Text
from forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Text -> Instrument
Util.instrument Text
to)

modify_allocations :: Ui.M m => Instrument
    -> (UiConfig.Allocation -> Map ScoreT.Instrument UiConfig.Allocation
        -> Map ScoreT.Instrument UiConfig.Allocation)
    -> m ()
modify_allocations :: forall (m :: * -> *).
M m =>
Text
-> (Allocation
    -> Map Instrument Allocation -> Map Instrument Allocation)
-> m ()
modify_allocations Text
inst Allocation
-> Map Instrument Allocation -> Map Instrument Allocation
modify = do
    Allocation
alloc <- forall (m :: * -> *). M m => Text -> m Allocation
get_allocation Text
inst
    forall (m :: * -> *). M m => (Config -> Config) -> m ()
Ui.modify_config forall a b. (a -> b) -> a -> b
$ Lens Config (Map Instrument Allocation)
UiConfig.allocations_map forall f a. Lens f a -> (a -> a) -> f -> f
%= Allocation
-> Map Instrument Allocation -> Map Instrument Allocation
modify Allocation
alloc

-- ** Common.Config

-- | Toggle and return the new value.
mute :: Ui.M m => Instrument -> m Bool
mute :: forall (m :: * -> *). M m => Text -> m Bool
mute = forall (m :: * -> *) a.
M m =>
(Config -> (Config, a)) -> Text -> m a
modify_common_config forall a b. (a -> b) -> a -> b
$ \Config
config ->
    let mute :: Bool
mute = Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ Config -> Bool
Common.config_mute Config
config
    in (Config
config { config_mute :: Bool
Common.config_mute = Bool
mute }, Bool
mute)

-- | Toggle and return the new value.
solo :: Ui.M m => Instrument -> m Bool
solo :: forall (m :: * -> *). M m => Text -> m Bool
solo = forall (m :: * -> *) a.
M m =>
(Config -> (Config, a)) -> Text -> m a
modify_common_config forall a b. (a -> b) -> a -> b
$ \Config
config ->
    let solo :: Bool
solo = Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ Config -> Bool
Common.config_solo Config
config
    in (Config
config { config_solo :: Bool
Common.config_solo = Bool
solo }, Bool
solo)

-- | Add an environ val to the instrument config.
add_environ :: (REnv.ToVal a, Ui.M m) => Env.Key -> a -> Instrument -> m ()
add_environ :: forall a (m :: * -> *). (ToVal a, M m) => Text -> a -> Text -> m ()
add_environ Text
name a
val = forall (m :: * -> *). M m => (Config -> Config) -> Text -> m ()
modify_common_config_ forall a b. (a -> b) -> a -> b
$ forall a. ToVal a => Text -> a -> Config -> Config
Common.add_cenviron Text
name a
val

-- | Clear the instrument config's environ.  The instrument's built-in environ
-- from 'Patch.patch_environ' is still present.
clear_environ :: Ui.M m => Instrument -> m ()
clear_environ :: forall (m :: * -> *). M m => Text -> m ()
clear_environ = forall (m :: * -> *). M m => (Config -> Config) -> Text -> m ()
modify_common_config_ forall a b. (a -> b) -> a -> b
$ Config :-> Environ
Common.cenviron forall f a. Lens f a -> a -> f -> f
#= forall a. Monoid a => a
mempty

-- ** Midi.Patch.Config

set_addr :: Ui.M m => Text -> [Channel1] -> Instrument -> m ()
set_addr :: forall (m :: * -> *). M m => Text -> [Channel1] -> Text -> m ()
set_addr Text
wdev [Channel1]
chans = forall (m :: * -> *). M m => (Config -> Config) -> Text -> m ()
modify_midi_config_ forall a b. (a -> b) -> a -> b
$
    Config :-> [(Addr, Maybe Int)]
Patch.allocation forall f a. Lens f a -> a -> f -> f
#= [((WriteDevice
dev, Channel1 -> Channel
to_chan Channel1
chan), forall a. Maybe a
Nothing) | Channel1
chan <- [Channel1]
chans]
    where dev :: WriteDevice
dev = Text -> WriteDevice
Midi.write_device Text
wdev

set_chans :: Ui.M m => [Channel1] -> Instrument -> m ()
set_chans :: forall (m :: * -> *). M m => [Channel1] -> Text -> m ()
set_chans [Channel1]
chans = forall (m :: * -> *). M m => (Config -> Config) -> Text -> m ()
modify_midi_config_ forall a b. (a -> b) -> a -> b
$ \Config
config ->
    case Config -> [(Addr, Maybe Int)]
Patch.config_allocation Config
config of
        ((WriteDevice
dev, Channel
_), Maybe Int
_) : [(Addr, Maybe Int)]
_ -> Config :-> [(Addr, Maybe Int)]
Patch.allocation
            #= [((dev, to_chan chan), Nothing) | chan <- chans] $
                Config
config
        [] -> Config
config

set_controls :: Ui.M m => [(ScoreT.Control, Signal.Y)] -> Instrument -> m ()
set_controls :: forall (m :: * -> *). M m => [(Control, Double)] -> Text -> m ()
set_controls [(Control, Double)]
controls = forall (m :: * -> *). M m => (Config -> Config) -> Text -> m ()
modify_common_config_ forall a b. (a -> b) -> a -> b
$
    Config :-> ControlValMap
Common.controls forall f a. Lens f a -> a -> f -> f
#= forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Control, Double)]
controls

set_control :: Ui.M m => ScoreT.Control -> Maybe Signal.Y -> Instrument -> m ()
set_control :: forall (m :: * -> *).
M m =>
Control -> Maybe Double -> Text -> m ()
set_control Control
control Maybe Double
val = forall (m :: * -> *). M m => (Config -> Config) -> Text -> m ()
modify_common_config_ forall a b. (a -> b) -> a -> b
$
    Config :-> ControlValMap
Common.controls forall a b c. Lens a b -> Lens b c -> Lens a c
# forall k a. Ord k => k -> Lens (Map k a) (Maybe a)
Lens.map Control
control forall f a. Lens f a -> a -> f -> f
#= Maybe Double
val

set_tuning_scale :: Ui.M m => Text -> Patch.Scale -> Instrument -> m ()
set_tuning_scale :: forall (m :: * -> *). M m => Text -> Scale -> Text -> m ()
set_tuning_scale Text
tuning Scale
scale Text
inst = do
    forall (m :: * -> *). M m => Scale -> Text -> m ()
set_scale Scale
scale Text
inst
    forall a (m :: * -> *). (ToVal a, M m) => Text -> a -> Text -> m ()
add_environ Text
EnvKey.tuning Text
tuning Text
inst

set_control_defaults :: Ui.M m => [(ScoreT.Control, Signal.Y)] -> Instrument
    -> m ()
set_control_defaults :: forall (m :: * -> *). M m => [(Control, Double)] -> Text -> m ()
set_control_defaults [(Control, Double)]
controls = forall (m :: * -> *). M m => (Config -> Config) -> Text -> m ()
modify_midi_config_ forall a b. (a -> b) -> a -> b
$
    Config :-> Settings
Patch.settingsforall a b c. Lens a b -> Lens b c -> Lens a c
#Settings :-> Maybe ControlValMap
Patch.control_defaults forall f a. Lens f a -> a -> f -> f
#= forall a. a -> Maybe a
Just (forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Control, Double)]
controls)

-- ** Midi.Patch.Config settings

get_scale :: Cmd.M m => ScoreT.Instrument -> m (Maybe Patch.Scale)
get_scale :: forall (m :: * -> *). M m => Instrument -> m (Maybe Scale)
get_scale Instrument
inst =
    (Config :-> Settings
Patch.settingsforall a b c. Lens a b -> Lens b c -> Lens a c
#Settings :-> Maybe Scale
Patch.scale #$) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
(Stack, M m) =>
Instrument -> m (Patch, Config)
Cmd.get_midi_instrument Instrument
inst

set_scale :: Ui.M m => Patch.Scale -> Instrument -> m ()
set_scale :: forall (m :: * -> *). M m => Scale -> Text -> m ()
set_scale Scale
scale = forall (m :: * -> *). M m => (Config -> Config) -> Text -> m ()
modify_midi_config_ forall a b. (a -> b) -> a -> b
$ Config :-> Settings
Patch.settingsforall a b c. Lens a b -> Lens b c -> Lens a c
#Settings :-> Maybe Scale
Patch.scale forall f a. Lens f a -> a -> f -> f
#= forall a. a -> Maybe a
Just Scale
scale

copy_scale :: Cmd.M m => Instrument -> Instrument -> m ()
copy_scale :: forall (m :: * -> *). M m => Text -> Text -> m ()
copy_scale Text
from Text
to = do
    Scale
scale <- forall (m :: * -> *) a. (Stack, M m) => Text -> Maybe a -> m a
Cmd.require Text
"no scale" forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). M m => Instrument -> m (Maybe Scale)
get_scale (Text -> Instrument
Util.instrument Text
from)
    forall (m :: * -> *). M m => Scale -> Text -> m ()
set_scale Scale
scale Text
to

pressure :: Ui.M m => Instrument -> m ()
pressure :: forall (m :: * -> *). M m => Text -> m ()
pressure = forall (m :: * -> *). M m => Flag -> Text -> m ()
add_flag Flag
Patch.Pressure

add_flag :: Ui.M m => Patch.Flag -> Instrument -> m ()
add_flag :: forall (m :: * -> *). M m => Flag -> Text -> m ()
add_flag Flag
flag = forall (m :: * -> *). M m => (Config -> Config) -> Text -> m ()
modify_midi_config_ forall a b. (a -> b) -> a -> b
$
    Config :-> Settings
Patch.settingsforall a b c. Lens a b -> Lens b c -> Lens a c
#Settings :-> Maybe (Set Flag)
Patch.flags forall f a. Lens f a -> (a -> a) -> f -> f
%= forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Flag -> Set Flag -> Set Flag
Patch.add_flag Flag
flag forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a -> a
fromMaybe forall a. Monoid a => a
mempty

remove_flag :: Ui.M m => Patch.Flag -> Instrument -> m ()
remove_flag :: forall (m :: * -> *). M m => Flag -> Text -> m ()
remove_flag Flag
flag = forall (m :: * -> *). M m => (Config -> Config) -> Text -> m ()
modify_midi_config_ forall a b. (a -> b) -> a -> b
$
    Config :-> Settings
Patch.settingsforall a b c. Lens a b -> Lens b c -> Lens a c
#Settings :-> Maybe (Set Flag)
Patch.flags
        forall f a. Lens f a -> (a -> a) -> f -> f
%= forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Flag -> Set Flag -> Set Flag
Patch.remove_flag Flag
flag forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a -> a
fromMaybe forall a. Monoid a => a
mempty

-- | Reset all settings back to instrument defaults.
reset_settings :: Ui.M m => Instrument -> m ()
reset_settings :: forall (m :: * -> *). M m => Text -> m ()
reset_settings = forall (m :: * -> *). M m => (Config -> Config) -> Text -> m ()
modify_midi_config_ forall a b. (a -> b) -> a -> b
$ Config :-> Settings
Patch.settings forall f a. Lens f a -> a -> f -> f
#= forall a. Monoid a => a
mempty

reset_flags :: Ui.M m => Instrument -> m ()
reset_flags :: forall (m :: * -> *). M m => Text -> m ()
reset_flags = forall (m :: * -> *). M m => (Config -> Config) -> Text -> m ()
modify_midi_config_ forall a b. (a -> b) -> a -> b
$
    Config :-> Settings
Patch.settingsforall a b c. Lens a b -> Lens b c -> Lens a c
#Settings :-> Maybe (Set Flag)
Patch.flags forall f a. Lens f a -> a -> f -> f
#= forall a. Maybe a
Nothing

set_decay :: Ui.M m => Maybe RealTime -> Instrument -> m ()
set_decay :: forall (m :: * -> *). M m => Maybe RealTime -> Text -> m ()
set_decay Maybe RealTime
decay = forall (m :: * -> *). M m => (Config -> Config) -> Text -> m ()
modify_midi_config_ forall a b. (a -> b) -> a -> b
$ Config :-> Settings
Patch.settingsforall a b c. Lens a b -> Lens b c -> Lens a c
#Settings :-> Maybe RealTime
Patch.decay forall f a. Lens f a -> a -> f -> f
#= Maybe RealTime
decay

set_pb_range :: Ui.M m => Maybe Patch.PbRange -> Instrument -> m ()
set_pb_range :: forall (m :: * -> *). M m => Maybe PbRange -> Text -> m ()
set_pb_range Maybe PbRange
range =
    forall (m :: * -> *). M m => (Config -> Config) -> Text -> m ()
modify_midi_config_ forall a b. (a -> b) -> a -> b
$ Config :-> Settings
Patch.settingsforall a b c. Lens a b -> Lens b c -> Lens a c
#Settings :-> Maybe PbRange
Patch.pitch_bend_range forall f a. Lens f a -> a -> f -> f
#= Maybe PbRange
range

-- * util

get_midi_config :: Ui.M m => ScoreT.Instrument
    -> m (InstT.Qualified, Common.Config, Patch.Config)
get_midi_config :: forall (m :: * -> *).
M m =>
Instrument -> m (Qualified, Config, Config)
get_midi_config Instrument
inst =
    forall (m :: * -> *) a. (Stack, M m) => Text -> Maybe a -> m a
Ui.require (Text
"not a midi instrument: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Instrument
inst)
        forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *).
M m =>
Instrument -> m (Maybe (Qualified, Config, Config))
lookup_midi_config Instrument
inst

lookup_midi_config :: Ui.M m => ScoreT.Instrument
    -> m (Maybe (InstT.Qualified, Common.Config, Patch.Config))
lookup_midi_config :: forall (m :: * -> *).
M m =>
Instrument -> m (Maybe (Qualified, Config, Config))
lookup_midi_config Instrument
inst = do
    UiConfig.Allocation Qualified
qualified Config
config Backend
backend
        <- forall (m :: * -> *). M m => Instrument -> m Allocation
get_instrument_allocation Instrument
inst
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Backend
backend of
        UiConfig.Midi Config
midi_config -> forall a. a -> Maybe a
Just (Qualified
qualified, Config
config, Config
midi_config)
        Backend
_ -> forall a. Maybe a
Nothing

modify_config :: Ui.M m =>
    (Common.Config -> Patch.Config -> ((Common.Config, Patch.Config), a))
    -> Instrument -> m a
modify_config :: forall (m :: * -> *) a.
M m =>
(Config -> Config -> ((Config, Config), a)) -> Text -> m a
modify_config Config -> Config -> ((Config, Config), a)
modify Text
inst_ = do
    let inst :: Instrument
inst = Text -> Instrument
Util.instrument Text
inst_
    (Qualified
qualified, Config
common, Config
midi) <- forall (m :: * -> *).
M m =>
Instrument -> m (Qualified, Config, Config)
get_midi_config Instrument
inst
    let ((Config
new_common, Config
new_midi), a
result) = Config -> Config -> ((Config, Config), a)
modify Config
common Config
midi
        new :: Allocation
new = Qualified -> Config -> Backend -> Allocation
UiConfig.Allocation Qualified
qualified Config
new_common (Config -> Backend
UiConfig.Midi Config
new_midi)
    forall (m :: * -> *). M m => (Config -> Config) -> m ()
Ui.modify_config forall a b. (a -> b) -> a -> b
$ Lens Config (Map Instrument Allocation)
UiConfig.allocations_map forall f a. Lens f a -> (a -> a) -> f -> f
%= forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Instrument
inst Allocation
new
    forall (m :: * -> *) a. Monad m => a -> m a
return a
result

modify_midi_config_ :: Ui.M m => (Patch.Config -> Patch.Config) -> Instrument
    -> m ()
modify_midi_config_ :: forall (m :: * -> *). M m => (Config -> Config) -> Text -> m ()
modify_midi_config_ Config -> Config
modify =
    forall (m :: * -> *) a.
M m =>
(Config -> Config -> ((Config, Config), a)) -> Text -> m a
modify_config forall a b. (a -> b) -> a -> b
$ \Config
common Config
midi -> ((Config
common, Config -> Config
modify Config
midi), ())

modify_common_config :: Ui.M m => (Common.Config -> (Common.Config, a))
    -> Instrument -> m a
modify_common_config :: forall (m :: * -> *) a.
M m =>
(Config -> (Config, a)) -> Text -> m a
modify_common_config Config -> (Config, a)
modify Text
inst_ = do
    let inst :: Instrument
inst = Text -> Instrument
Util.instrument Text
inst_
    Allocation
alloc <- forall (m :: * -> *). M m => Instrument -> m Allocation
get_instrument_allocation Instrument
inst
    let (Config
config, a
result) = Config -> (Config, a)
modify (Allocation -> Config
UiConfig.alloc_config Allocation
alloc)
        new :: Allocation
new = Allocation
alloc { alloc_config :: Config
UiConfig.alloc_config = Config
config }
    forall (m :: * -> *). M m => (Config -> Config) -> m ()
Ui.modify_config forall a b. (a -> b) -> a -> b
$ Lens Config (Map Instrument Allocation)
UiConfig.allocations_map forall f a. Lens f a -> (a -> a) -> f -> f
%= forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Instrument
inst Allocation
new
    forall (m :: * -> *) a. Monad m => a -> m a
return a
result

modify_common_config_ :: Ui.M m => (Common.Config -> Common.Config)
    -> Instrument -> m ()
modify_common_config_ :: forall (m :: * -> *). M m => (Config -> Config) -> Text -> m ()
modify_common_config_ Config -> Config
modify =
    forall (m :: * -> *) a.
M m =>
(Config -> (Config, a)) -> Text -> m a
modify_common_config forall a b. (a -> b) -> a -> b
$ \Config
config -> (Config -> Config
modify Config
config, ())

get_instrument_allocation :: Ui.M m => ScoreT.Instrument
    -> m UiConfig.Allocation
get_instrument_allocation :: forall (m :: * -> *). M m => Instrument -> m Allocation
get_instrument_allocation Instrument
inst =
    forall (m :: * -> *) a. (Stack, M m) => Text -> Maybe a -> m a
Ui.require (Text
"no allocation for " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Instrument
inst)
        forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Instrument -> Lens State (Maybe Allocation)
Ui.allocation Instrument
inst forall (f :: * -> *) a b. Functor f => Lens a b -> f a -> f b
<#> forall (m :: * -> *). M m => m State
Ui.get


-- * Cmd.EditState

set_attrs :: Cmd.M m => Text -> Instrument -> m ()
set_attrs :: forall (m :: * -> *). M m => Text -> Text -> m ()
set_attrs Text
attrs Text
inst_ = do
    let inst :: Instrument
inst = Text -> Instrument
Util.instrument Text
inst_
    forall (m :: * -> *).
(Stack, M m) =>
Instrument -> m ResolvedInstrument
Cmd.get_instrument Instrument
inst -- ensure that it exists
    Val
val <- forall (m :: * -> *) err a.
(Stack, M m) =>
(err -> Text) -> Either err a -> m a
Cmd.require_right (Text
"parsing attrs: " <>) forall a b. (a -> b) -> a -> b
$
        Text -> Either Text Val
Parse.parse_val (Text
"+" forall a. Semigroup a => a -> a -> a
<> Text
attrs)
    Attributes
attrs <- forall (m :: * -> *) err a.
(Stack, M m) =>
(err -> Text) -> Either err a -> m a
Cmd.require_right forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ forall a. Typecheck a => Val -> Either Text a
Typecheck.typecheck_simple Val
val
    forall (m :: * -> *). M m => Instrument -> Attributes -> m ()
Cmd.set_instrument_attributes Instrument
inst Attributes
attrs

-- * find

find :: Cmd.M m => Text -> m [Text]
find :: forall (m :: * -> *). M m => Text -> m [Text]
find Text
substr = do
    InstrumentDb
db <- forall (m :: * -> *) a. M m => (State -> a) -> m a
Cmd.gets forall a b. (a -> b) -> a -> b
$ Config -> InstrumentDb
Cmd.config_instrument_db forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Config
Cmd.state_config
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Text
substr `Text.isInfixOf`)
        [ Qualified -> Text
InstT.show_qualified forall a b. (a -> b) -> a -> b
$ Text -> Text -> Qualified
InstT.Qualified Text
synth Text
inst
        | (Text
synth, Synth InstrumentCode
s) <- forall code. Db code -> [(Text, Synth code)]
Inst.synths InstrumentDb
db
        , Text
inst <- forall k a. Map k a -> [k]
Map.keys forall a b. (a -> b) -> a -> b
$ forall code. Synth code -> Map Text (Inst code)
Inst.synth_insts Synth InstrumentCode
s
        ]


-- * change_instrument

-- | Replace the instrument in the current track with the given one, and
-- 'initialize_midi' it.  This is intended for hardware synths which need a
-- program change or sysex.  It's called by "Instrument.Browser".
set_instrument :: Cmd.M m => Qualified -> m ()
set_instrument :: forall (m :: * -> *). M m => Text -> m ()
set_instrument Text
new_qualified = do
    Qualified
new_qualified <- forall (m :: * -> *). M m => Text -> m Qualified
parse_qualified Text
new_qualified
    TrackId
track_id <- forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => m (BlockId, TrackId)
Selection.event_track
    Instrument
inst <- forall (m :: * -> *) a. (Stack, M m) => Text -> Maybe a -> m a
Cmd.require Text
"must select a note track"
        forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> Maybe Instrument
ParseTitle.title_to_instrument forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => TrackId -> m Text
Ui.get_track_title TrackId
track_id
    (Qualified
_, Config
common_config, Config
midi_config) <- forall (m :: * -> *).
M m =>
Instrument -> m (Qualified, Config, Config)
get_midi_config Instrument
inst
    -- Replace the old instrument and reuse its addr.
    forall (m :: * -> *). M m => Instrument -> m ()
deallocate Instrument
inst
    forall (m :: * -> *). M m => Instrument -> Allocation -> m ()
allocate Instrument
inst forall a b. (a -> b) -> a -> b
$ Qualified -> Config -> Backend -> Allocation
UiConfig.Allocation Qualified
new_qualified Config
common_config
        (Config -> Backend
UiConfig.Midi Config
midi_config)
    forall (m :: * -> *). M m => Instrument -> m ()
initialize_inst Instrument
inst

block_instruments :: BlockId -> Cmd.CmdL [ScoreT.Instrument]
block_instruments :: BlockId -> CmdL [Instrument]
block_instruments BlockId
block_id = do
    [Text]
titles <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a -> b) -> [a] -> [b]
map TrackInfo -> Text
Ui.track_title) (forall (m :: * -> *). M m => BlockId -> m [TrackInfo]
TrackTree.tracks_of BlockId
block_id)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Text -> Maybe Instrument
ParseTitle.title_to_instrument [Text]
titles

-- | Synths default to writing to a device with their name.  You'll have to
-- map it to a real hardware WriteDevice in the 'Cmd.Cmd.write_device_map'.
device_of :: ScoreT.Instrument -> Cmd.CmdL Midi.WriteDevice
device_of :: Instrument -> CmdL WriteDevice
device_of Instrument
inst = do
    InstT.Qualified Text
synth Text
_ <- ResolvedInstrument -> Qualified
Cmd.inst_qualified forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
(Stack, M m) =>
Instrument -> m ResolvedInstrument
Cmd.get_instrument Instrument
inst
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text -> WriteDevice
Midi.write_device Text
synth


-- * midi interface

-- | Every read device on the system, along with any aliases it may have.
read_devices :: Cmd.CmdL [(Midi.ReadDevice, [Midi.ReadDevice])]
read_devices :: CmdL [(ReadDevice, [ReadDevice])]
read_devices = forall a. (Interface -> IO a) -> CmdL a
run_interface forall write_message.
RawInterface write_message -> IO [(ReadDevice, [ReadDevice])]
Interface.read_devices

-- | Every write device on the system, along with any aliases it may have.
write_devices :: Cmd.CmdL [(Midi.WriteDevice, [Midi.WriteDevice])]
write_devices :: CmdL [(WriteDevice, [WriteDevice])]
write_devices = forall a. (Interface -> IO a) -> CmdL a
run_interface forall write_message.
RawInterface write_message -> IO [(WriteDevice, [WriteDevice])]
Interface.write_devices

connect_read_device :: Midi.ReadDevice -> Cmd.CmdL Bool
connect_read_device :: ReadDevice -> CmdL Bool
connect_read_device ReadDevice
rdev =
    forall a. (Interface -> IO a) -> CmdL a
run_interface (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall write_message.
RawInterface write_message -> ReadDevice -> IO Bool
Interface.connect_read_device ReadDevice
rdev)

disconnect_read_device :: Midi.ReadDevice -> Cmd.CmdL Bool
disconnect_read_device :: ReadDevice -> CmdL Bool
disconnect_read_device ReadDevice
rdev =
    forall a. (Interface -> IO a) -> CmdL a
run_interface (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall write_message.
RawInterface write_message -> ReadDevice -> IO Bool
Interface.disconnect_read_device ReadDevice
rdev)

run_interface :: (Interface.Interface -> IO a) -> Cmd.CmdL a
run_interface :: forall a. (Interface -> IO a) -> CmdL a
run_interface Interface -> IO a
op = do
    Interface
interface <- forall (m :: * -> *) a. M m => (State -> a) -> m a
Cmd.gets (Config -> Interface
Cmd.config_midi_interface forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Config
Cmd.state_config)
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Interface -> IO a
op Interface
interface)


-- * misc

save :: FilePath -> Cmd.CmdL ()
save :: [Char] -> CmdL ()
save = [Char] -> CmdL ()
Save.save_allocations

load :: FilePath -> Cmd.CmdL ()
load :: [Char] -> CmdL ()
load [Char]
fname = do
    Allocations
allocs <- [Char] -> CmdT IO Allocations
Save.load_allocations [Char]
fname
    forall (m :: * -> *). M m => (Config -> Config) -> m ()
Ui.modify_config forall a b. (a -> b) -> a -> b
$ Config :-> Allocations
UiConfig.allocations forall f a. Lens f a -> a -> f -> f
#= Allocations
allocs

-- | Load and merge instruments.  If there are name collisions, the
-- already-allocated instrument wins.
load_merge :: FilePath -> Cmd.CmdL ()
load_merge :: [Char] -> CmdL ()
load_merge [Char]
fname = forall (m :: * -> *). M m => Bool -> Allocations -> m ()
merge Bool
False forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Char] -> CmdT IO Allocations
Save.load_allocations [Char]
fname

-- | Send a CC MIDI message on the given device and channel.  This is for
-- synths that use MIDI learn.
teach :: Text -> Channel1 -> Midi.Control -> Cmd.CmdL ()
teach :: Text -> Channel1 -> Channel -> CmdL ()
teach Text
dev Channel1
chan Channel
cc = forall (m :: * -> *). M m => WriteDevice -> Message -> m ()
Cmd.midi (Text -> WriteDevice
Midi.write_device Text
dev) forall a b. (a -> b) -> a -> b
$
    Channel -> ChannelMessage -> Message
Midi.ChannelMessage (Channel1 -> Channel
to_chan Channel1
chan) (Channel -> Channel -> ChannelMessage
Midi.ControlChange Channel
cc Channel
1)

-- | This is parsed into a 'Inst.Qualified'.
type Qualified = Text

parse_qualified :: Cmd.M m => Qualified -> m InstT.Qualified
parse_qualified :: forall (m :: * -> *). M m => Text -> m Qualified
parse_qualified Text
text
    | Text
"/" Text -> Text -> Bool
`Text.isInfixOf` Text
text = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text -> Qualified
InstT.parse_qualified Text
text
    | Bool
otherwise =
        forall (m :: * -> *) a. (Stack, M m) => Text -> m a
Cmd.throw forall a b. (a -> b) -> a -> b
$ Text
"qualified inst name lacks a /: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Text
text


-- * initialize

-- | Initialize all instruments that need it.
initialize_all :: Cmd.CmdT IO ()
initialize_all :: CmdL ()
initialize_all = do
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *). M m => Instrument -> m ()
initialize_inst forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). M m => m [Instrument]
allocated
    CmdL ()
sc_initialize

-- | List allocated instruments that need initialization.
need_initialization :: Ui.M m => m Text
need_initialization :: forall (m :: * -> *). M m => m Text
need_initialization = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Text] -> Text
Text.unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM forall {f :: * -> *}. M f => Instrument -> f (Maybe Text)
show1 forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). M m => m [Instrument]
allocated
    where
    show1 :: Instrument -> f (Maybe Text)
show1 Instrument
inst = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Initialization
init -> forall a. Pretty a => a -> Text
pretty Instrument
inst forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Initialization
init) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        forall (m :: * -> *). M m => Instrument -> m (Maybe Initialization)
inst_initialization Instrument
inst

inst_initialization :: Ui.M m => ScoreT.Instrument
    -> m (Maybe Patch.Initialization)
inst_initialization :: forall (m :: * -> *). M m => Instrument -> m (Maybe Initialization)
inst_initialization Instrument
inst = forall (m :: * -> *).
M m =>
Instrument -> m (Maybe (Qualified, Config, Config))
lookup_midi_config Instrument
inst forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
    Maybe (Qualified, Config, Config)
Nothing -> forall a. Maybe a
Nothing
    Just (Qualified
_, Config
_, Config
config) -> Config -> Maybe Initialization
Patch.config_initialization Config
config

-- | Initialize an instrument according to its 'Patch.config_initialization'.
initialize_inst :: Cmd.M m => ScoreT.Instrument -> m ()
initialize_inst :: forall (m :: * -> *). M m => Instrument -> m ()
initialize_inst Instrument
inst =
    forall (m :: * -> *) a.
Monad m =>
m (Maybe a) -> (a -> m ()) -> m ()
whenJustM (forall (m :: * -> *).
M m =>
Instrument -> m (Maybe (Qualified, Config, Config))
lookup_midi_config Instrument
inst) forall a b. (a -> b) -> a -> b
$ \(Qualified
_, Config
_, Config
config) -> do
        forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust (Config -> Maybe Initialization
Patch.config_initialization Config
config) forall a b. (a -> b) -> a -> b
$ \case
            Initialization
Patch.Tuning -> forall (m :: * -> *). M m => Instrument -> m ()
initialize_realtime_tuning Instrument
inst
            Initialization
Patch.NrpnTuning -> forall (m :: * -> *). M m => Instrument -> m ()
initialize_nrpn_tuning Instrument
inst
        (Patch
patch, Config
_) <- forall (m :: * -> *).
(Stack, M m) =>
Instrument -> m (Patch, Config)
Cmd.get_midi_instrument Instrument
inst
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Config -> [Addr]
Patch.config_addrs Config
config) forall a b. (a -> b) -> a -> b
$ \Addr
addr ->
            forall (m :: * -> *).
M m =>
Instrument -> Addr -> InitializePatch -> m ()
send_midi_initialize Instrument
inst Addr
addr (Patch -> InitializePatch
Patch.patch_initialize Patch
patch)

-- | Send a MIDI tuning message to retune the synth to its 'Patch.Scale'.  Very
-- few synths support this, I only know of pianoteq.
initialize_realtime_tuning :: Cmd.M m => ScoreT.Instrument -> m ()
initialize_realtime_tuning :: forall (m :: * -> *). M m => Instrument -> m ()
initialize_realtime_tuning Instrument
inst = do
    [(Key, Double)]
keys <- forall (m :: * -> *). M m => Instrument -> m [(Key, Double)]
get_tuning_map Instrument
inst
    (Qualified
_, Config
_, Config
config) <- forall (m :: * -> *).
M m =>
Instrument -> m (Qualified, Config, Config)
get_midi_config Instrument
inst
    let msg :: Message
msg = [(Key, Double)] -> Message
Midi.realtime_tuning [(Key, Double)]
keys
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *). M m => WriteDevice -> Message -> m ()
Cmd.midi Message
msg)
        (forall a. Ord a => [a] -> [a]
Lists.unique (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst (Config -> [Addr]
Patch.config_addrs Config
config)))

-- | Like 'initialize_realtime_tuning', except use 'Midi.nrpn_tuning'.
initialize_nrpn_tuning :: Cmd.M m => ScoreT.Instrument -> m ()
initialize_nrpn_tuning :: forall (m :: * -> *). M m => Instrument -> m ()
initialize_nrpn_tuning Instrument
inst = do
    [(Key, Double)]
keys <- forall (m :: * -> *). M m => Instrument -> m [(Key, Double)]
get_tuning_map Instrument
inst
    (Qualified
_, Config
_, Config
config) <- forall (m :: * -> *).
M m =>
Instrument -> m (Qualified, Config, Config)
get_midi_config Instrument
inst
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a. Ord a => [a] -> [a]
Lists.unique (Config -> [Addr]
Patch.config_addrs Config
config)) forall a b. (a -> b) -> a -> b
$ \(WriteDevice
dev, Channel
chan) ->
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall (m :: * -> *). M m => WriteDevice -> Message -> m ()
Cmd.midi WriteDevice
dev forall b c a. (b -> c) -> (a -> b) -> a -> c
. Channel -> ChannelMessage -> Message
Midi.ChannelMessage Channel
chan) ([(Key, Double)] -> [ChannelMessage]
Midi.nrpn_tuning [(Key, Double)]
keys)

get_tuning_map :: Cmd.M m => ScoreT.Instrument
    -> m [(Midi.Key, Midi.NoteNumber)]
get_tuning_map :: forall (m :: * -> *). M m => Instrument -> m [(Key, Double)]
get_tuning_map Instrument
inst = forall (m :: * -> *). M m => Instrument -> m (Maybe Scale)
get_scale Instrument
inst forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe Scale
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return []
    Just Scale
scale -> do
        AttributeMap
attr_map <- Patch -> AttributeMap
Patch.patch_attribute_map 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 (m :: * -> *).
(Stack, M m) =>
Instrument -> m (Patch, Config)
Cmd.get_midi_instrument Instrument
inst
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second NoteNumber -> Double
Pitch.nn_to_double) forall a b. (a -> b) -> a -> b
$
            Maybe AttributeMap -> Scale -> [(Key, NoteNumber)]
Patch.scale_nns (forall a. a -> Maybe a
Just AttributeMap
attr_map) Scale
scale

initialize_midi :: Cmd.M m => ScoreT.Instrument -> Patch.Addr -> m ()
initialize_midi :: forall (m :: * -> *). M m => Instrument -> Addr -> m ()
initialize_midi Instrument
inst Addr
addr = do
    (Patch
patch, Config
_) <- forall (m :: * -> *).
(Stack, M m) =>
Instrument -> m (Patch, Config)
Cmd.get_midi_instrument Instrument
inst
    forall (m :: * -> *).
M m =>
Instrument -> Addr -> InitializePatch -> m ()
send_midi_initialize Instrument
inst Addr
addr (Patch -> InitializePatch
Patch.patch_initialize Patch
patch)

send_midi_initialize :: Cmd.M m => ScoreT.Instrument -> Patch.Addr
    -> Patch.InitializePatch -> m ()
send_midi_initialize :: forall (m :: * -> *).
M m =>
Instrument -> Addr -> InitializePatch -> m ()
send_midi_initialize Instrument
inst (WriteDevice
dev, Channel
chan) = \case
    Patch.InitializeMidi [Message]
msgs -> do
        forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.notice forall a b. (a -> b) -> a -> b
$ Text
"sending midi init: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty [Message]
msgs
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall (m :: * -> *). M m => WriteDevice -> Message -> m ()
Cmd.midi WriteDevice
dev forall b c a. (b -> c) -> (a -> b) -> a -> c
. Channel -> Message -> Message
Midi.set_channel Channel
chan) [Message]
msgs
    Patch.InitializeMessage Text
msg ->
        -- Warn doesn't seem quite right for this, but the whole point is to
        -- show this message, so it should be emphasized.
        forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.warn forall a b. (a -> b) -> a -> b
$ Text
"initialize instrument " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Instrument
inst forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> Text
msg
    InitializePatch
Patch.NoInitialization -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

sc_initialize :: Cmd.CmdT IO ()
sc_initialize :: CmdL ()
sc_initialize = do
    [Instrument]
insts <- forall (m :: * -> *) a. M m => (Config -> a) -> m a
Ui.get_config forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [k]
Map.keys forall b c a. (b -> c) -> (a -> b) -> a -> c
. Allocations -> Map Instrument Allocation
UiConfig.unallocations
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config -> Allocations
UiConfig.config_allocations
    [ResolvedInstrument]
insts <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *).
(Stack, M m) =>
Instrument -> m ResolvedInstrument
Cmd.get_instrument [Instrument]
insts
    [Patch] -> CmdL ()
sc_initialize_patches forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ResolvedInstrument -> Maybe Patch
Cmd.sc_patch [ResolvedInstrument]
insts

sc_initialize_patches :: [Sc.Patch.Patch] -> Cmd.CmdT IO ()
sc_initialize_patches :: [Patch] -> CmdL ()
sc_initialize_patches [] = forall (m :: * -> *) a. Monad m => a -> m a
return ()
sc_initialize_patches [Patch]
patches = do
    -- scsynth has a /d_free, but seems to have no way to query what is
    -- actually loaded, so it's sort of useless, because you must control the
    -- scsynth lifecycle to manually track what it loaded, and at that point
    -- you may as well restart it.
    -- TODO if configured with the path to scsynth, I could start it
    -- automatically.  In that case, I may want to send a /quit on exit.
    Text
msg <- forall (m :: * -> *) err a.
(Stack, M m) =>
(err -> Text) -> Either err a -> m a
Cmd.require_right (Text
"can't initialize sc patches: "<>)
        forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Either Text Text)
Sc.Play.version
    -- TODO: when called from REPL, log msgs are collected together, so
    -- "waiting for" is not very interesting.
    forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.notice forall a b. (a -> b) -> a -> b
$ Text
"found scsynth: " forall a. Semigroup a => a -> a -> a
<> Text
msg
    forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.notice forall a b. (a -> b) -> a -> b
$ Text
"loading patches: "
        forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
Text.unwords (forall a b. (a -> b) -> [a] -> [b]
map (forall a. Textlike a => a -> Text
Texts.toText forall b c a. (b -> c) -> (a -> b) -> a -> c
. Patch -> PatchName
Sc.Patch.name) [Patch]
patches)
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Patch -> IO ()
Sc.Play.initialize_patch [Patch]
patches
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
Sc.Play.sync
    forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.notice Text
"waiting for sync"