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

-- | Utilities for the instrument definitions in "Local.Instrument".
module Cmd.Instrument.MidiInst (
    Synth, synth
    , make_inst
    -- * code
    , make_code
    , Code(..), Call
    , generator, transformer, both, note_calls
    , note_generators, note_transformers, val_calls
    , null_call, null_calls
    , postproc, cmd, thru

    -- * Patch
    , Patch(..), patch, common
    , make_patch, patch_from_pair, named_patch, default_patch
    -- ** modify
    , dummy, code, doc, attribute_map, decay, synth_controls
    , add_flag, add_flags, pressure, add_common_flag, triggered
    , control_defaults
    -- ** environ
    , environ, default_scale, range, nn_range
    -- ** per-allocation
    , inst_range
    -- * allocations
    , allocations, config, config1

    -- * types
    , Load, MakeDb
) where
import qualified Data.Map as Map
import qualified Data.Set as Set

import qualified Util.Doc as Doc
import qualified Util.Lens as Lens
import qualified Util.Pretty as Pretty

import qualified App.Path as Path
import qualified Cmd.Cmd as Cmd
import qualified Derive.Call.Module as Module
import qualified Derive.Derive as Derive
import qualified Derive.Env as Env
import qualified Derive.EnvKey as EnvKey
import qualified Derive.Expr as Expr
import qualified Derive.Library as Library
import qualified Derive.REnv as REnv
import qualified Derive.Scale as Scale
import qualified Derive.ScoreT as ScoreT
import qualified Derive.Symbols as Symbols

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.Midi.Control as Control
import qualified Perform.Midi.Patch as Patch
import qualified Perform.Pitch as Pitch
import qualified Perform.Signal as Signal

import qualified Ui.UiConfig as UiConfig

import           Global
import           Types


type Synth = Inst.SynthDecl Cmd.InstrumentCode

synth :: InstT.SynthName -> Text -> [Patch] -> Synth
synth :: SynthName -> SynthName -> [Patch] -> Synth
synth SynthName
name SynthName
doc [Patch]
patches =
    SynthName
-> SynthName -> [(SynthName, Inst InstrumentCode)] -> Synth
forall code.
SynthName
-> SynthName -> [(SynthName, Inst code)] -> SynthDecl code
Inst.SynthDecl SynthName
name SynthName
doc ([SynthName]
-> [Inst InstrumentCode] -> [(SynthName, Inst InstrumentCode)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((Patch -> SynthName) -> [Patch] -> [SynthName]
forall a b. (a -> b) -> [a] -> [b]
map Patch -> SynthName
name_of [Patch]
patches) ((Patch -> Inst InstrumentCode) -> [Patch] -> [Inst InstrumentCode]
forall a b. (a -> b) -> [a] -> [b]
map Patch -> Inst InstrumentCode
make_inst [Patch]
patches))
    where name_of :: Patch -> SynthName
name_of = (Patch :-> Patch
patch(Patch :-> Patch) -> Lens Patch SynthName -> Lens Patch SynthName
forall a b c. Lens a b -> Lens b c -> Lens a c
#Lens Patch SynthName
Patch.name #$)

make_inst :: Patch -> Inst.Inst Cmd.InstrumentCode
make_inst :: Patch -> Inst InstrumentCode
make_inst (Patch Patch
patch Maybe SynthName
dummy Common Code
common) = Inst.Inst
    { inst_backend :: Backend
inst_backend = case Maybe SynthName
dummy of
        Maybe SynthName
Nothing -> Patch -> Backend
Inst.Midi Patch
patch
        Just SynthName
msg -> SynthName -> Backend
Inst.Dummy SynthName
msg
    , inst_common :: Common InstrumentCode
inst_common = Common Code
common
        { common_code :: InstrumentCode
Common.common_code = Code -> InstrumentCode
make_code (Common Code -> Code
forall code. Common code -> code
Common.common_code Common Code
common) }
    }

make_code :: Code -> Cmd.InstrumentCode
make_code :: Code -> InstrumentCode
make_code (Code Library
library InstrumentPostproc
postproc [HandlerId]
cmds Maybe ThruFunction
thru) = Cmd.InstrumentCode
    { inst_calls :: InstrumentCalls
inst_calls = Library -> InstrumentCalls
compile_library Library
library
    , inst_postproc :: InstrumentPostproc
inst_postproc = InstrumentPostproc
postproc
    , inst_cmds :: [HandlerId]
inst_cmds = [HandlerId]
cmds
    , inst_thru :: Maybe ThruFunction
inst_thru = Maybe ThruFunction
thru
    }

-- | InstrumentCalls doesn't have modules, so just pull everything out of every
-- module.
compile_library :: Library.Library -> Derive.InstrumentCalls
compile_library :: Library -> InstrumentCalls
compile_library = ScopesT
  (Scope
     (Map Module (CallMap (Generator Note)))
     (ModuleMap (Generator Control))
     (ModuleMap (Generator Pitch)))
  (Scope
     (Map Module (CallMap (Transformer Note)))
     (ModuleMap (Transformer Control))
     (ModuleMap (Transformer Pitch)))
  (Scope
     (Map Module (CallMap (TrackCall Note)))
     (ModuleMap (TrackCall Control))
     (ModuleMap (TrackCall Pitch)))
  (Map Module (CallMap ValCall))
-> InstrumentCalls
forall {a} {control} {pitch} {a} {control} {pitch} {a} {control}
       {pitch} {a}.
ScopesT
  (Scope (Map Module (CallMap a)) control pitch)
  (Scope (Map Module (CallMap a)) control pitch)
  (Scope (Map Module (CallMap a)) control pitch)
  (Map Module (CallMap a))
-> ScopesT (CallMap a) (CallMap a) (CallMap a) (CallMap a)
convert (ScopesT
   (Scope
      (Map Module (CallMap (Generator Note)))
      (ModuleMap (Generator Control))
      (ModuleMap (Generator Pitch)))
   (Scope
      (Map Module (CallMap (Transformer Note)))
      (ModuleMap (Transformer Control))
      (ModuleMap (Transformer Pitch)))
   (Scope
      (Map Module (CallMap (TrackCall Note)))
      (ModuleMap (TrackCall Control))
      (ModuleMap (TrackCall Pitch)))
   (Map Module (CallMap ValCall))
 -> InstrumentCalls)
-> (Library
    -> ScopesT
         (Scope
            (Map Module (CallMap (Generator Note)))
            (ModuleMap (Generator Control))
            (ModuleMap (Generator Pitch)))
         (Scope
            (Map Module (CallMap (Transformer Note)))
            (ModuleMap (Transformer Control))
            (ModuleMap (Transformer Pitch)))
         (Scope
            (Map Module (CallMap (TrackCall Note)))
            (ModuleMap (TrackCall Control))
            (ModuleMap (TrackCall Pitch)))
         (Map Module (CallMap ValCall)))
-> Library
-> InstrumentCalls
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ScopesT
   (Scope
      (Map Module (CallMap (Generator Note)))
      (ModuleMap (Generator Control))
      (ModuleMap (Generator Pitch)))
   (Scope
      (Map Module (CallMap (Transformer Note)))
      (ModuleMap (Transformer Control))
      (ModuleMap (Transformer Pitch)))
   (Scope
      (Map Module (CallMap (TrackCall Note)))
      (ModuleMap (TrackCall Control))
      (ModuleMap (TrackCall Pitch)))
   (Map Module (CallMap ValCall)),
 [Shadowed])
-> ScopesT
     (Scope
        (Map Module (CallMap (Generator Note)))
        (ModuleMap (Generator Control))
        (ModuleMap (Generator Pitch)))
     (Scope
        (Map Module (CallMap (Transformer Note)))
        (ModuleMap (Transformer Control))
        (ModuleMap (Transformer Pitch)))
     (Scope
        (Map Module (CallMap (TrackCall Note)))
        (ModuleMap (TrackCall Control))
        (ModuleMap (TrackCall Pitch)))
     (Map Module (CallMap ValCall))
forall a b. (a, b) -> a
fst ((ScopesT
    (Scope
       (Map Module (CallMap (Generator Note)))
       (ModuleMap (Generator Control))
       (ModuleMap (Generator Pitch)))
    (Scope
       (Map Module (CallMap (Transformer Note)))
       (ModuleMap (Transformer Control))
       (ModuleMap (Transformer Pitch)))
    (Scope
       (Map Module (CallMap (TrackCall Note)))
       (ModuleMap (TrackCall Control))
       (ModuleMap (TrackCall Pitch)))
    (Map Module (CallMap ValCall)),
  [Shadowed])
 -> ScopesT
      (Scope
         (Map Module (CallMap (Generator Note)))
         (ModuleMap (Generator Control))
         (ModuleMap (Generator Pitch)))
      (Scope
         (Map Module (CallMap (Transformer Note)))
         (ModuleMap (Transformer Control))
         (ModuleMap (Transformer Pitch)))
      (Scope
         (Map Module (CallMap (TrackCall Note)))
         (ModuleMap (TrackCall Control))
         (ModuleMap (TrackCall Pitch)))
      (Map Module (CallMap ValCall)))
-> (Library
    -> (ScopesT
          (Scope
             (Map Module (CallMap (Generator Note)))
             (ModuleMap (Generator Control))
             (ModuleMap (Generator Pitch)))
          (Scope
             (Map Module (CallMap (Transformer Note)))
             (ModuleMap (Transformer Control))
             (ModuleMap (Transformer Pitch)))
          (Scope
             (Map Module (CallMap (TrackCall Note)))
             (ModuleMap (TrackCall Control))
             (ModuleMap (TrackCall Pitch)))
          (Map Module (CallMap ValCall)),
        [Shadowed]))
-> Library
-> ScopesT
     (Scope
        (Map Module (CallMap (Generator Note)))
        (ModuleMap (Generator Control))
        (ModuleMap (Generator Pitch)))
     (Scope
        (Map Module (CallMap (Transformer Note)))
        (ModuleMap (Transformer Control))
        (ModuleMap (Transformer Pitch)))
     (Scope
        (Map Module (CallMap (TrackCall Note)))
        (ModuleMap (TrackCall Control))
        (ModuleMap (TrackCall Pitch)))
     (Map Module (CallMap ValCall))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Library
-> (ScopesT
      (Scope
         (Map Module (CallMap (Generator Note)))
         (ModuleMap (Generator Control))
         (ModuleMap (Generator Pitch)))
      (Scope
         (Map Module (CallMap (Transformer Note)))
         (ModuleMap (Transformer Control))
         (ModuleMap (Transformer Pitch)))
      (Scope
         (Map Module (CallMap (TrackCall Note)))
         (ModuleMap (TrackCall Control))
         (ModuleMap (TrackCall Pitch)))
      (Map Module (CallMap ValCall)),
    [Shadowed])
Library.compile
    where
    convert :: ScopesT
  (Scope (Map Module (CallMap a)) control pitch)
  (Scope (Map Module (CallMap a)) control pitch)
  (Scope (Map Module (CallMap a)) control pitch)
  (Map Module (CallMap a))
-> ScopesT (CallMap a) (CallMap a) (CallMap a) (CallMap a)
convert (Derive.Scopes Scope (Map Module (CallMap a)) control pitch
gen Scope (Map Module (CallMap a)) control pitch
trans Scope (Map Module (CallMap a)) control pitch
track Map Module (CallMap a)
val) = Derive.Scopes
        { scopes_generator :: CallMap a
scopes_generator = Map Module (CallMap a) -> CallMap a
forall a. Map Module (CallMap a) -> CallMap a
extract (Map Module (CallMap a) -> CallMap a)
-> Map Module (CallMap a) -> CallMap a
forall a b. (a -> b) -> a -> b
$ Scope (Map Module (CallMap a)) control pitch
-> Map Module (CallMap a)
forall note control pitch. Scope note control pitch -> note
Derive.scope_note Scope (Map Module (CallMap a)) control pitch
gen
        , scopes_transformer :: CallMap a
scopes_transformer = Map Module (CallMap a) -> CallMap a
forall a. Map Module (CallMap a) -> CallMap a
extract (Map Module (CallMap a) -> CallMap a)
-> Map Module (CallMap a) -> CallMap a
forall a b. (a -> b) -> a -> b
$ Scope (Map Module (CallMap a)) control pitch
-> Map Module (CallMap a)
forall note control pitch. Scope note control pitch -> note
Derive.scope_note Scope (Map Module (CallMap a)) control pitch
trans
        , scopes_track :: CallMap a
scopes_track = Map Module (CallMap a) -> CallMap a
forall a. Map Module (CallMap a) -> CallMap a
extract (Map Module (CallMap a) -> CallMap a)
-> Map Module (CallMap a) -> CallMap a
forall a b. (a -> b) -> a -> b
$ Scope (Map Module (CallMap a)) control pitch
-> Map Module (CallMap a)
forall note control pitch. Scope note control pitch -> note
Derive.scope_note Scope (Map Module (CallMap a)) control pitch
track
        , scopes_val :: CallMap a
scopes_val = Map Module (CallMap a) -> CallMap a
forall a. Map Module (CallMap a) -> CallMap a
extract Map Module (CallMap a)
val
        }
    -- TODO this doesn't warn about shadowed entries, but I'd have to extend
    -- 'synth' to be in LogMonad.
    extract :: Map Module.Module (Derive.CallMap a) -> Derive.CallMap a
    extract :: forall a. Map Module (CallMap a) -> CallMap a
extract = [CallMap a] -> CallMap a
forall a. Monoid a => [a] -> a
mconcat ([CallMap a] -> CallMap a)
-> (Map Module (CallMap a) -> [CallMap a])
-> Map Module (CallMap a)
-> CallMap a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Module (CallMap a) -> [CallMap a]
forall k a. Map k a -> [a]
Map.elems

-- * code

-- | A version of 'Cmd.InstrumentCode' that's more convenient for record update
-- syntax.
data Code = Code {
    Code -> Library
code_library :: !Library.Library
    , Code -> InstrumentPostproc
code_postproc :: !Cmd.InstrumentPostproc
    , Code -> [HandlerId]
code_cmds :: ![Cmd.HandlerId]
    , Code -> Maybe ThruFunction
code_thru :: !(Maybe Cmd.ThruFunction)
    }

instance Pretty Code where
    format :: Code -> Doc
format (Code Library
library InstrumentPostproc
_postproc [HandlerId]
cmds Maybe ThruFunction
thru) =
        Doc -> [(SynthName, Doc)] -> Doc
Pretty.record Doc
"Code"
            [ (SynthName
"library", Library -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Library
library)
            , (SynthName
"cmds", Int -> Doc
forall a. Pretty a => a -> Doc
Pretty.format (Int -> Doc) -> Int -> Doc
forall a b. (a -> b) -> a -> b
$ [HandlerId] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [HandlerId]
cmds)
            , (SynthName
"thru", Maybe ThruFunction -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Maybe ThruFunction
thru)
            ]

instance Semigroup Code where
    <> :: Code -> Code -> Code
(<>)    (Code Library
lib1 InstrumentPostproc
post1 [HandlerId]
cmds1 Maybe ThruFunction
thru1)
            (Code Library
lib2 InstrumentPostproc
post2 [HandlerId]
cmds2 Maybe ThruFunction
thru2) =
        Library
-> InstrumentPostproc -> [HandlerId] -> Maybe ThruFunction -> Code
Code (Library
lib1Library -> Library -> Library
forall a. Semigroup a => a -> a -> a
<>Library
lib2) (InstrumentPostproc -> InstrumentPostproc -> InstrumentPostproc
forall b c log a.
(b -> (c, [log])) -> (a -> (b, [log])) -> a -> (c, [log])
merge InstrumentPostproc
post1 InstrumentPostproc
post2) ([HandlerId]
cmds1[HandlerId] -> [HandlerId] -> [HandlerId]
forall a. Semigroup a => a -> a -> a
<>[HandlerId]
cmds2) (Maybe ThruFunction
thru1Maybe ThruFunction -> Maybe ThruFunction -> Maybe ThruFunction
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>Maybe ThruFunction
thru2)
instance Monoid Code where
    mempty :: Code
mempty = Library
-> InstrumentPostproc -> [HandlerId] -> Maybe ThruFunction -> Code
Code Library
forall a. Monoid a => a
mempty (,[]) [] Maybe ThruFunction
forall a. Maybe a
Nothing
    mappend :: Code -> Code -> Code
mappend = Code -> Code -> Code
forall a. Semigroup a => a -> a -> a
(<>)

merge :: (b -> (c, [log])) -> (a -> (b, [log])) -> (a -> (c, [log]))
merge :: forall b c log a.
(b -> (c, [log])) -> (a -> (b, [log])) -> a -> (c, [log])
merge b -> (c, [log])
f1 a -> (b, [log])
f2 = (\(b
b, [log]
logs) -> ([log]
logs++) ([log] -> [log]) -> (c, [log]) -> (c, [log])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> b -> (c, [log])
f1 b
b) ((b, [log]) -> (c, [log])) -> (a -> (b, [log])) -> a -> (c, [log])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> (b, [log])
f2

-- ** code constructors

-- | Bundle together generators and transformers.  The rationale is described
-- in 'Derive.CallMaps'.
data Call d =
    Generator Expr.Symbol (Derive.Generator d)
    | Transformer Expr.Symbol (Derive.Transformer d)
    | Both Expr.Symbol (Derive.Generator d) (Derive.Transformer d)

generator :: Expr.Symbol -> Derive.Generator d -> Call d
generator :: forall d. Symbol -> Generator d -> Call d
generator = Symbol -> Generator d -> Call d
forall d. Symbol -> Generator d -> Call d
Generator

transformer :: Expr.Symbol -> Derive.Transformer d -> Call d
transformer :: forall d. Symbol -> Transformer d -> Call d
transformer = Symbol -> Transformer d -> Call d
forall d. Symbol -> Transformer d -> Call d
Transformer

both :: Expr.Symbol -> Library.Calls d -> Call d
both :: forall d. Symbol -> Calls d -> Call d
both Symbol
name Calls d
calls =
    Symbol -> Generator d -> Transformer d -> Call d
forall d. Symbol -> Generator d -> Transformer d -> Call d
Both Symbol
name (Calls d -> Generator d
forall d. Calls d -> Generator d
Library.generator Calls d
calls) (Calls d -> Transformer d
forall d. Calls d -> Transformer d
Library.transformer Calls d
calls)

-- | Add the given call as the null note call to the note track.  This also
-- binds 'Symbols.default_note', since that's supposed to be the \"named\" way
-- to call \"\".
null_call :: Derive.Generator Derive.Note -> Code
null_call :: Generator Note -> Code
null_call = [Call Note] -> Code
note_calls ([Call Note] -> Code)
-> (Generator Note -> [Call Note]) -> Generator Note -> Code
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Generator Note -> [Call Note]
null_calls

null_calls :: Derive.Generator Derive.Note -> [Call Derive.Note]
null_calls :: Generator Note -> [Call Note]
null_calls Generator Note
call =
    [ Symbol -> Generator Note -> Call Note
forall d. Symbol -> Generator d -> Call d
generator Symbol
Symbols.null_note Generator Note
call
    , Symbol -> Generator Note -> Call Note
forall d. Symbol -> Generator d -> Call d
generator Symbol
Symbols.default_note Generator Note
call
    ]

note_calls :: [Call Derive.Note] -> Code
note_calls :: [Call Note] -> Code
note_calls [Call Note]
calls =
    [(Symbol, Generator Note)] -> Code
note_generators ([(Symbol
name, Generator Note
c) | Generator Symbol
name Generator Note
c <- [Call Note]
calls]
        [(Symbol, Generator Note)]
-> [(Symbol, Generator Note)] -> [(Symbol, Generator Note)]
forall a. [a] -> [a] -> [a]
++ [(Symbol
name, Generator Note
c) | Both Symbol
name Generator Note
c Transformer Note
_ <- [Call Note]
calls])
    Code -> Code -> Code
forall a. Semigroup a => a -> a -> a
<> [(Symbol, Transformer Note)] -> Code
note_transformers ([(Symbol
name, Transformer Note
c) | Transformer Symbol
name Transformer Note
c <- [Call Note]
calls]
        [(Symbol, Transformer Note)]
-> [(Symbol, Transformer Note)] -> [(Symbol, Transformer Note)]
forall a. [a] -> [a] -> [a]
++ [(Symbol
name, Transformer Note
c) | Both Symbol
name Generator Note
_ Transformer Note
c <- [Call Note]
calls])

-- | Add the given calls to the note track scope.
note_generators :: [(Expr.Symbol, Derive.Generator Derive.Note)] -> Code
note_generators :: [(Symbol, Generator Note)] -> Code
note_generators [(Symbol, Generator Note)]
calls = Code
forall a. Monoid a => a
mempty { code_library :: Library
code_library = [(Symbol, Generator Note)] -> Library
forall call.
ToLibrary (Generator call) =>
[(Symbol, Generator call)] -> Library
Library.generators [(Symbol, Generator Note)]
calls }

-- | Add the given calls to the note track scope.
note_transformers :: [(Expr.Symbol, Derive.Transformer Derive.Note)] -> Code
note_transformers :: [(Symbol, Transformer Note)] -> Code
note_transformers [(Symbol, Transformer Note)]
calls = Code
forall a. Monoid a => a
mempty { code_library :: Library
code_library = [(Symbol, Transformer Note)] -> Library
forall call.
ToLibrary (Transformer call) =>
[(Symbol, Transformer call)] -> Library
Library.transformers [(Symbol, Transformer Note)]
calls }

val_calls :: [(Expr.Symbol, Derive.ValCall)] -> Code
val_calls :: [(Symbol, ValCall)] -> Code
val_calls [(Symbol, ValCall)]
calls = Code
forall a. Monoid a => a
mempty { code_library :: Library
code_library = [(Symbol, ValCall)] -> Library
Library.vals [(Symbol, ValCall)]
calls }

postproc :: Cmd.InstrumentPostproc -> Code
postproc :: InstrumentPostproc -> Code
postproc InstrumentPostproc
post = Code
forall a. Monoid a => a
mempty { code_postproc :: InstrumentPostproc
code_postproc = InstrumentPostproc
post }

cmd :: Cmd.HandlerId -> Code
cmd :: HandlerId -> Code
cmd HandlerId
c = Code
forall a. Monoid a => a
mempty { code_cmds :: [HandlerId]
code_cmds = [HandlerId
c] }

thru :: Cmd.ThruFunction -> Code
thru :: ThruFunction -> Code
thru ThruFunction
f = Code
forall a. Monoid a => a
mempty { code_thru :: Maybe ThruFunction
code_thru = ThruFunction -> Maybe ThruFunction
forall a. a -> Maybe a
Just ThruFunction
f }

-- * Patch

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

patch :: Patch :-> Patch
patch = (Patch -> Patch)
-> ((Patch -> Patch) -> 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 = (Patch -> Common Code)
-> ((Common Code -> Common Code) -> Patch -> Patch)
-> Patch :-> Common Code
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) })

instance Pretty Patch where
    format :: Patch -> Doc
format (Patch Patch
patch Maybe SynthName
dummy Common Code
common) = Doc -> [(SynthName, Doc)] -> Doc
Pretty.record Doc
"Patch"
        [ (SynthName
"patch", Patch -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Patch
patch)
        , (SynthName
"dummy", Maybe SynthName -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Maybe SynthName
dummy)
        , (SynthName
"common", Common Code -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Common Code
common)
        ]

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

-- | Convert patches as emitted by 'Patch.Sysex.Patch'.
patch_from_pair :: (Patch.Patch, Common.Common ()) -> Patch
patch_from_pair :: (Patch, Common ()) -> Patch
patch_from_pair (Patch
patch, Common ()
common) = (Patch -> Patch
make_patch Patch
patch)
    { patch_common :: Common Code
patch_common = Common ()
common { common_code :: Code
Common.common_code = Code
forall a. Monoid a => a
mempty } }

-- | Make a patch, with a few parameters that tend to be unique per patch.
-- Controls come last because they are often a long list.
--
-- TODO I don't love the name, but 'patch' is already taken by the lens.
named_patch :: Control.PbRange -> InstT.Name
    -> [(Midi.Control, ScoreT.Control)] -> Patch
named_patch :: PbRange -> SynthName -> [(Control, Control)] -> Patch
named_patch PbRange
pb_range SynthName
name [(Control, Control)]
controls =
    Patch -> Patch
make_patch (Patch -> Patch) -> Patch -> Patch
forall a b. (a -> b) -> a -> b
$ (PbRange -> SynthName -> Patch
Patch.patch PbRange
pb_range SynthName
name)
        { patch_control_map :: ControlMap
Patch.patch_control_map = [(Control, Control)] -> ControlMap
Control.control_map [(Control, Control)]
controls }

-- | Make a default patch for the synth.
default_patch :: Control.PbRange -> [(Midi.Control, ScoreT.Control)] -> Patch
default_patch :: PbRange -> [(Control, Control)] -> Patch
default_patch PbRange
pb_range [(Control, Control)]
controls =
    Patch -> Patch
make_patch (Patch -> Patch) -> Patch -> Patch
forall a b. (a -> b) -> a -> b
$ (PbRange -> SynthName -> Patch
Patch.patch PbRange
pb_range SynthName
Patch.default_name)
        { patch_control_map :: ControlMap
Patch.patch_control_map = [(Control, Control)] -> ControlMap
Control.control_map [(Control, Control)]
controls }

-- ** modify

dummy :: Text -> Patch -> Patch
dummy :: SynthName -> Patch -> Patch
dummy SynthName
msg Patch
patch = Patch
patch { patch_dummy :: Maybe SynthName
patch_dummy = SynthName -> Maybe SynthName
forall a. a -> Maybe a
Just SynthName
msg }

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

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

attribute_map :: Lens Patch Patch.AttributeMap
attribute_map :: Lens Patch AttributeMap
attribute_map = Patch :-> Patch
patch (Patch :-> Patch)
-> Lens Patch AttributeMap -> Lens Patch AttributeMap
forall a b c. Lens a b -> Lens b c -> Lens a c
# Lens Patch AttributeMap
Patch.attribute_map

decay :: Lens Patch (Maybe RealTime)
decay :: Lens Patch (Maybe RealTime)
decay = Patch :-> Patch
patch (Patch :-> Patch)
-> Lens Patch (Maybe RealTime) -> Lens Patch (Maybe RealTime)
forall a b c. Lens a b -> Lens b c -> Lens a c
# Patch :-> Settings
Patch.defaults (Patch :-> Settings)
-> Lens Settings (Maybe RealTime) -> Lens Patch (Maybe RealTime)
forall a b c. Lens a b -> Lens b c -> Lens a c
# Lens Settings (Maybe RealTime)
Patch.decay

-- | Annotate all the patches with some global controls.
synth_controls :: [(Midi.Control, ScoreT.Control)] -> [Patch] -> [Patch]
synth_controls :: [(Control, Control)] -> [Patch] -> [Patch]
synth_controls [(Control, Control)]
controls = (Patch -> Patch) -> [Patch] -> [Patch]
forall a b. (a -> b) -> [a] -> [b]
map ((Patch -> Patch) -> [Patch] -> [Patch])
-> (Patch -> Patch) -> [Patch] -> [Patch]
forall a b. (a -> b) -> a -> b
$
    Patch :-> Patch
patch (Patch :-> Patch) -> Lens Patch ControlMap -> Lens Patch ControlMap
forall a b c. Lens a b -> Lens b c -> Lens a c
# Lens Patch ControlMap
Patch.control_map Lens Patch ControlMap
-> (ControlMap -> ControlMap) -> Patch -> Patch
forall f a. Lens f a -> (a -> a) -> f -> f
%= ([(Control, Control)] -> ControlMap
Control.control_map [(Control, Control)]
controls <>)

add_flag :: Patch.Flag -> Patch.Patch -> Patch.Patch
add_flag :: Flag -> Patch -> Patch
add_flag Flag
flag =
    Patch :-> Settings
Patch.defaults(Patch :-> Settings)
-> Lens Settings (Maybe (Set Flag))
-> Lens Patch (Maybe (Set Flag))
forall a b c. Lens a b -> Lens b c -> Lens a c
#Lens Settings (Maybe (Set Flag))
Patch.flags Lens Patch (Maybe (Set Flag))
-> (Maybe (Set Flag) -> Maybe (Set Flag)) -> Patch -> Patch
forall f a. Lens f a -> (a -> a) -> f -> f
%= Set Flag -> Maybe (Set Flag)
forall a. a -> Maybe a
Just (Set Flag -> Maybe (Set Flag))
-> (Maybe (Set Flag) -> Set Flag)
-> Maybe (Set Flag)
-> Maybe (Set Flag)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Flag -> Set Flag -> Set Flag
Patch.add_flag Flag
flag (Set Flag -> Set Flag)
-> (Maybe (Set Flag) -> Set Flag) -> Maybe (Set Flag) -> Set Flag
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Flag -> Maybe (Set Flag) -> Set Flag
forall a. a -> Maybe a -> a
fromMaybe Set Flag
forall a. Monoid a => a
mempty

add_flags :: [Patch.Flag] -> Patch.Patch -> Patch.Patch
add_flags :: [Flag] -> Patch -> Patch
add_flags [Flag]
flags = Patch :-> Settings
Patch.defaults(Patch :-> Settings)
-> Lens Settings (Maybe (Set Flag))
-> Lens Patch (Maybe (Set Flag))
forall a b c. Lens a b -> Lens b c -> Lens a c
#Lens Settings (Maybe (Set Flag))
Patch.flags
    Lens Patch (Maybe (Set Flag))
-> (Maybe (Set Flag) -> Maybe (Set Flag)) -> Patch -> Patch
forall f a. Lens f a -> (a -> a) -> f -> f
%= Set Flag -> Maybe (Set Flag)
forall a. a -> Maybe a
Just (Set Flag -> Maybe (Set Flag))
-> (Maybe (Set Flag) -> Set Flag)
-> Maybe (Set Flag)
-> Maybe (Set Flag)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Flag -> Set Flag -> Set Flag
forall a. Ord a => Set a -> Set a -> Set a
Set.union ([Flag] -> Set Flag
forall a. Ord a => [a] -> Set a
Set.fromList [Flag]
flags) (Set Flag -> Set Flag)
-> (Maybe (Set Flag) -> Set Flag) -> Maybe (Set Flag) -> Set Flag
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Flag -> Maybe (Set Flag) -> Set Flag
forall a. a -> Maybe a -> a
fromMaybe Set Flag
forall a. Monoid a => a
mempty

-- | Set a patch to pressure control.
pressure :: Patch -> Patch
pressure :: Patch -> Patch
pressure = Patch :-> Patch
patch (Patch :-> Patch) -> (Patch -> Patch) -> Patch -> Patch
forall f a. Lens f a -> (a -> a) -> f -> f
%= (Patch :-> Settings
Patch.defaults(Patch :-> Settings)
-> Lens Settings (Maybe RealTime) -> Lens Patch (Maybe RealTime)
forall a b c. Lens a b -> Lens b c -> Lens a c
#Lens Settings (Maybe RealTime)
Patch.decay Lens Patch (Maybe RealTime) -> Maybe RealTime -> Patch -> Patch
forall f a. Lens f a -> a -> f -> f
#= RealTime -> Maybe RealTime
forall a. a -> Maybe a
Just RealTime
0)
    (Patch -> Patch) -> (Patch -> Patch) -> Patch -> Patch
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Flag -> Patch -> Patch
add_flag Flag
Patch.Pressure

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

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

control_defaults :: [(ScoreT.Control, Signal.Y)] -> Patch -> Patch
control_defaults :: [(Control, Y)] -> Patch -> Patch
control_defaults [(Control, Y)]
controls =
    Patch :-> Patch
patch(Patch :-> Patch)
-> Lens Patch (Maybe ControlValMap)
-> Lens Patch (Maybe ControlValMap)
forall a b c. Lens a b -> Lens b c -> Lens a c
#Patch :-> Settings
Patch.defaults(Patch :-> Settings)
-> Lens Settings (Maybe ControlValMap)
-> Lens Patch (Maybe ControlValMap)
forall a b c. Lens a b -> Lens b c -> Lens a c
#Lens Settings (Maybe ControlValMap)
Patch.control_defaults Lens Patch (Maybe ControlValMap)
-> Maybe ControlValMap -> Patch -> Patch
forall f a. Lens f a -> a -> f -> f
#= ControlValMap -> Maybe ControlValMap
forall a. a -> Maybe a
Just ([(Control, Y)] -> ControlValMap
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Control, Y)]
controls)

-- ** environ

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

-- | The instrument will set the given scale when it comes into scope.
default_scale :: Pitch.ScaleId -> Patch -> Patch
default_scale :: ScaleId -> Patch -> Patch
default_scale = SynthName -> Str -> Patch -> Patch
forall a. ToVal a => SynthName -> a -> Patch -> Patch
environ SynthName
EnvKey.scale (Str -> Patch -> Patch)
-> (ScaleId -> Str) -> ScaleId -> Patch -> Patch
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScaleId -> Str
Expr.scale_id_to_str

-- | Set instrument range.
range :: Scale.Range -> Patch -> Patch
range :: Range -> Patch -> Patch
range Range
range = SynthName -> Pitch -> Patch -> Patch
forall a. ToVal a => SynthName -> a -> Patch -> Patch
environ SynthName
EnvKey.instrument_bottom (Range -> Pitch
Scale.range_bottom Range
range)
    (Patch -> Patch) -> (Patch -> Patch) -> Patch -> Patch
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SynthName -> Pitch -> Patch -> Patch
forall a. ToVal a => SynthName -> a -> Patch -> Patch
environ SynthName
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) = SynthName -> NoteNumber -> Patch -> Patch
forall a. ToVal a => SynthName -> a -> Patch -> Patch
environ SynthName
EnvKey.instrument_bottom NoteNumber
bottom
    (Patch -> Patch) -> (Patch -> Patch) -> Patch -> Patch
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SynthName -> NoteNumber -> Patch -> Patch
forall a. ToVal a => SynthName -> a -> Patch -> Patch
environ SynthName
EnvKey.instrument_top NoteNumber
top

-- ** per-allocation

-- | Like 'range', but set it in the allocation, not the patch.
inst_range :: Scale.Range -> Common.Config -> Common.Config
inst_range :: Range -> Config -> Config
inst_range Range
range =
    SynthName -> Pitch -> Config -> Config
forall a. ToVal a => SynthName -> a -> Config -> Config
Common.add_cenviron SynthName
EnvKey.instrument_bottom (Range -> Pitch
Scale.range_bottom Range
range)
    (Config -> Config) -> (Config -> Config) -> Config -> Config
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SynthName -> Pitch -> Config -> Config
forall a. ToVal a => SynthName -> a -> Config -> Config
Common.add_cenviron SynthName
EnvKey.instrument_top (Range -> Pitch
Scale.range_top Range
range)

-- * Allocations

allocations ::
    [(ScoreT.Instrument, InstT.Qualified,
        Common.Config -> Common.Config, UiConfig.Backend)]
    -- ^ (inst, qualified, set_config, backend)
    -> UiConfig.Allocations
allocations :: [(Instrument, Qualified, Config -> Config, Backend)] -> Allocations
allocations = [(Instrument, Allocation)] -> Allocations
UiConfig.make_allocations ([(Instrument, Allocation)] -> Allocations)
-> ([(Instrument, Qualified, Config -> Config, Backend)]
    -> [(Instrument, Allocation)])
-> [(Instrument, Qualified, Config -> Config, Backend)]
-> Allocations
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Instrument, Qualified, Config -> Config, Backend)
 -> (Instrument, Allocation))
-> [(Instrument, Qualified, Config -> Config, Backend)]
-> [(Instrument, Allocation)]
forall a b. (a -> b) -> [a] -> [b]
map (Instrument, Qualified, Config -> Config, Backend)
-> (Instrument, Allocation)
forall {a}.
(a, Qualified, Config -> Config, Backend) -> (a, Allocation)
make
    where
    make :: (a, Qualified, Config -> Config, Backend) -> (a, Allocation)
make (a
name, Qualified
qualified, Config -> Config
set_config, Backend
backend) =
        ( a
name
        , UiConfig.Allocation
            { alloc_qualified :: Qualified
alloc_qualified = Qualified
qualified
            , alloc_config :: Config
alloc_config = Config -> Config
set_config Config
Common.empty_config
            , alloc_backend :: Backend
alloc_backend = Backend
backend
            }
        )

-- | Create an incomplete Config.  It's incomplete because it doesn't have
-- the Settings from 'Patch.patch_defaults', so it'll need to have those
-- applied when it gets applied to 'UiConfig.state_allocations'.
config :: [Patch.Addr] -> Patch.Config
config :: [Addr] -> Config
config = [(Addr, Maybe Int)] -> Config
Patch.config ([(Addr, Maybe Int)] -> Config)
-> ([Addr] -> [(Addr, Maybe Int)]) -> [Addr] -> Config
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Addr -> (Addr, Maybe Int)) -> [Addr] -> [(Addr, Maybe Int)]
forall a b. (a -> b) -> [a] -> [b]
map (, Maybe Int
forall a. Maybe a
Nothing)

-- | Specialize 'config' for a single Addr.
config1 :: Midi.WriteDevice -> Midi.Channel -> Patch.Config
config1 :: WriteDevice -> Control -> Config
config1 WriteDevice
dev Control
chan = [Addr] -> Config
config [(WriteDevice
dev, Control
chan)]


-- * types

-- | Instrument definition modules that need to load from disk export a
-- function called @load@, with this signature.  Use the AppDir to find
-- 'Config.instrument_dir'.
type Load = Path.AppDir -> IO (Maybe Synth)


{- | Some synths may require a more expensive load, e.g. they could parse
    a directory full of sysex dumps.  These expose a @make_db@ function with
    this type.  As with 'Load', the FilePath is 'Config.instrument_dir'.  The
    function is expected to do its work and save the results in the instrument
    dir

    You should use 'Cmd.Instrument.MidiInst.save_synth', which will put the
    file into 'Config.instrument_cache_dir' with the same name as the synth.
-}
type MakeDb = Path.AppDir -> IO ()