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

-- | This is the 音 variant of "Cmd.Instrument.MidiInst".  All of the the
-- generic bits can be re-exported.
module Cmd.Instrument.ImInst (
    module Cmd.Instrument.ImInst, module MidiInst
) where
import qualified Data.Set as Set

import qualified Util.Doc as Doc
import qualified Util.Lens as Lens
import qualified Cmd.Cmd as Cmd
import qualified Cmd.EditUtil as EditUtil
import qualified Cmd.InputNote as InputNote
import qualified Cmd.Instrument.MidiInst as MidiInst
import           Cmd.Instrument.MidiInst
    (Code, allocations, both, cmd, generator, inst_range, make_code, note_calls,
     note_generators, note_transformers, null_call, postproc, transformer,
     val_calls)
import qualified Cmd.MidiThru as MidiThru

import qualified Derive.EnvKey as EnvKey
import qualified Derive.REnv as REnv
import qualified Derive.Scale as Scale
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 Perform.Im.Patch as Patch
import qualified Perform.Pitch as Pitch
import qualified Synth.Shared.Thru as Thru
import qualified Ui.UiConfig as UiConfig

import           Global


type Synth = Inst.SynthDecl Cmd.InstrumentCode

synth :: InstT.SynthName -> Text -> [(InstT.Name, Patch)] -> Synth
synth :: Text -> Text -> [(Text, Patch)] -> Synth
synth Text
name Text
doc [(Text, Patch)]
patches =
    forall code. Text -> Text -> [(Text, Inst code)] -> SynthDecl code
Inst.SynthDecl Text
name Text
doc (forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Patch -> Inst InstrumentCode
make_inst) [(Text, Patch)]
patches)

data Patch = Patch {
    Patch -> Patch
patch_patch :: Patch.Patch
    , Patch -> Maybe Text
patch_dummy :: Maybe Text
    , Patch -> Common Code
patch_common :: Common.Common Code
    }

make_patch :: Patch.Patch -> Patch
make_patch :: Patch -> Patch
make_patch Patch
p = Patch
    { patch_patch :: Patch
patch_patch = Patch
p
    , patch_dummy :: Maybe Text
patch_dummy = forall a. Maybe a
Nothing
    , patch_common :: Common Code
patch_common = forall code. code -> Common code
Common.common forall a. Monoid a => a
mempty
    }

patch :: Patch :-> Patch
patch = forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens Patch -> Patch
patch_patch (\Patch -> Patch
f Patch
r -> Patch
r { patch_patch :: Patch
patch_patch = Patch -> Patch
f (Patch -> Patch
patch_patch Patch
r) })
common :: Patch :-> Common Code
common = forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens Patch -> Common Code
patch_common
    (\Common Code -> Common Code
f Patch
r -> Patch
r { patch_common :: Common Code
patch_common = Common Code -> Common Code
f (Patch -> Common Code
patch_common Patch
r) })

-- | Cause this to have a Dummy backend.  It's a bit sloppy in that the
-- contents of 'patch_patch' will be ignored, but it's convenient in that
-- it lets me reuse all the functions in here for dummies too.
dummy :: Text -> Patch -> Patch
dummy :: Text -> Patch -> Patch
dummy Text
msg Patch
patch = Patch
patch { patch_dummy :: Maybe Text
patch_dummy = forall a. a -> Maybe a
Just Text
msg }

code :: Lens Patch Code
code :: Lens Patch Code
code = Patch :-> Common Code
common forall a b c. Lens a b -> Lens b c -> Lens a c
# forall {code}. Common code :-> code
Common.code

doc :: Lens Patch Doc.Doc
doc :: Lens Patch Doc
doc = Patch :-> Common Code
common forall a b c. Lens a b -> Lens b c -> Lens a c
# forall {code}. Common code :-> Doc
Common.doc

make_inst :: Patch -> Inst.Inst Cmd.InstrumentCode
make_inst :: Patch -> Inst InstrumentCode
make_inst (Patch Patch
patch Maybe Text
dummy Common Code
common) = Inst.Inst
    { inst_backend :: Backend
inst_backend = case Maybe Text
dummy of
        Maybe Text
Nothing -> Patch -> Backend
Inst.Im Patch
patch
        Just Text
msg -> Text -> Backend
Inst.Dummy Text
msg
    , inst_common :: Common InstrumentCode
inst_common = Code -> InstrumentCode
MidiInst.make_code forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Common Code
common
    }

-- TODO: these are copy paste from MidiInst, only 'common' is different.
-- I should be able to share the code.

-- | The instrument will also set the given environ when it comes into scope.
environ :: REnv.ToVal a => EnvKey.Key -> a -> Patch -> Patch
environ :: forall a. ToVal a => Text -> a -> Patch -> Patch
environ Text
name a
val = Patch :-> Common Code
common forall f a. Lens f a -> (a -> a) -> f -> f
%= forall a code. ToVal a => Text -> a -> Common code -> Common code
cenviron Text
name a
val

cenviron :: REnv.ToVal a => EnvKey.Key -> a
    -> Common.Common code -> Common.Common code
cenviron :: forall a code. ToVal a => Text -> a -> Common code -> Common code
cenviron Text
name a
val =
    forall {code}. Common code :-> Environ
Common.environ forall f a. Lens f a -> (a -> a) -> f -> f
%= ([(Text, Val)] -> Environ
REnv.from_list [(Text
name, forall a. ToVal a => a -> Val
REnv.to_val a
val)] <>)

-- | Set instrument range.
range :: Scale.Range -> Patch -> Patch
range :: Range -> Patch -> Patch
range Range
range = Patch :-> Common Code
common forall f a. Lens f a -> (a -> a) -> f -> f
%= forall code. Range -> Common code -> Common code
crange Range
range

crange :: Scale.Range -> Common.Common code -> Common.Common code
crange :: forall code. Range -> Common code -> Common code
crange Range
range =
    forall a code. ToVal a => Text -> a -> Common code -> Common code
cenviron Text
EnvKey.instrument_bottom (Range -> Pitch
Scale.range_bottom Range
range)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a code. ToVal a => Text -> a -> Common code -> Common code
cenviron Text
EnvKey.instrument_top (Range -> Pitch
Scale.range_top Range
range)

nn_range :: (Pitch.NoteNumber, Pitch.NoteNumber) -> Patch -> Patch
nn_range :: (NoteNumber, NoteNumber) -> Patch -> Patch
nn_range (NoteNumber
bottom, NoteNumber
top) =
    forall a. ToVal a => Text -> a -> Patch -> Patch
environ Text
EnvKey.instrument_bottom NoteNumber
bottom
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToVal a => Text -> a -> Patch -> Patch
environ Text
EnvKey.instrument_top NoteNumber
top

-- | Adapt a 'Thru.ThruFunction' to 'Cmd.ThruFunction'.
thru :: Thru.ThruFunction -> Code
thru :: ThruFunction -> Code
thru ThruFunction
thru_f = ThruFunction -> Code
MidiInst.thru forall {m :: * -> *}.
M m =>
Scale -> Attributes -> Input -> m [Thru]
convert
    where
    convert :: Scale -> Attributes -> Input -> m [Thru]
convert Scale
scale Attributes
attrs Input
input = do
        Instrument
inst <- forall (m :: * -> *) a. M m => Maybe a -> m a
Cmd.abort_unless forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). M m => m (Maybe Instrument)
EditUtil.lookup_instrument
        forall (m :: * -> *).
M m =>
Instrument -> Scale -> Input -> m InputNn
MidiThru.convert_input Instrument
inst Scale
scale Input
input forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            InputNote.NoteOn NoteId
_ NoteNumber
pitch Y
velocity ->
                case ThruFunction
thru_f [NoteNumber -> Y -> Attributes -> Int -> Note
Thru.Note NoteNumber
pitch Y
velocity Attributes
attrs Int
0] of
                    Left Text
err -> forall (m :: * -> *) a. (Stack, M m) => Text -> m a
Cmd.throw Text
err
                    Right Message
msg -> forall (m :: * -> *) a. Monad m => a -> m a
return [Message -> Thru
Cmd.ImThru Message
msg]
            InputNn
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return []

add_flag :: Common.Flag -> Patch -> Patch
add_flag :: Flag -> Patch -> Patch
add_flag Flag
flag = Patch :-> Common Code
commonforall a b c. Lens a b -> Lens b c -> Lens a c
#forall {code}. Common code :-> Set Flag
Common.flags forall f a. Lens f a -> (a -> a) -> f -> f
%= forall a. Ord a => a -> Set a -> Set a
Set.insert Flag
flag

triggered :: Patch -> Patch
triggered :: Patch -> Patch
triggered = Flag -> Patch -> Patch
add_flag Flag
Common.Triggered

im_allocations :: [(ScoreT.Instrument, Text, Common.Config -> Common.Config)]
    -- ^ (inst, qualified, set_config)
    -> UiConfig.Allocations
im_allocations :: [(Instrument, Text, Config -> Config)] -> Allocations
im_allocations = [(Instrument, Allocation)] -> Allocations
UiConfig.make_allocations forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall a. Backend -> (a, Text, Config -> Config) -> (a, Allocation)
_make_allocation Backend
UiConfig.Im)

dummy_allocations :: [(ScoreT.Instrument, Text, Common.Config -> Common.Config)]
    -- ^ (inst, qualified, set_config)
    -> UiConfig.Allocations
dummy_allocations :: [(Instrument, Text, Config -> Config)] -> Allocations
dummy_allocations =
    [(Instrument, Allocation)] -> Allocations
UiConfig.make_allocations forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall a. Backend -> (a, Text, Config -> Config) -> (a, Allocation)
_make_allocation (Text -> Backend
UiConfig.Dummy Text
""))

_make_allocation :: UiConfig.Backend
    -> (a, Text, Common.Config -> Common.Config) -> (a, UiConfig.Allocation)
_make_allocation :: forall a. Backend -> (a, Text, Config -> Config) -> (a, Allocation)
_make_allocation Backend
backend (a
name, Text
qualified, Config -> Config
set_config) =
    ( a
name
    , UiConfig.Allocation
        { alloc_qualified :: Qualified
alloc_qualified = Text -> Qualified
InstT.parse_qualified Text
qualified
        , alloc_config :: Config
alloc_config = Config -> Config
set_config Config
Common.empty_config
        , alloc_backend :: Backend
alloc_backend = Backend
backend
        }
    )