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

{-# LANGUAGE DeriveFunctor #-}
-- | This contains instrument data in common between different backends.
module Instrument.Common where
import qualified Data.List as List
import qualified Data.Maybe as Maybe
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 Util.Seq as Seq
import qualified Util.Serialize as Serialize

import qualified Derive.Attrs as Attrs
import qualified Derive.EnvKey as EnvKey
import qualified Derive.Expr as Expr
import qualified Derive.REnv as REnv
import qualified Derive.ScoreT as ScoreT
import qualified Derive.ShowVal as ShowVal

import qualified Instrument.Tag as Tag

import           Global


-- | Attributes common to all instruments.  Unlike 'Config', these are
-- part of the instrument itself and not configurable.
data Common code = Common {
    -- | Cmds and Derive calls.  This is abstract so this can be defined
    -- without incurring a dependency on "Cmd.Cmd", which would wind up being
    -- a circular dependency.
    forall code. Common code -> code
common_code :: !code
    -- | This environ is merged into the derive environ when the instrument
    -- comes into scope, and also when the pitch of 'Score.Event's with this
    -- instrument is converted.  Typically it sets things like instrument
    -- range, tuning details, etc.
    , forall code. Common code -> Environ
common_environ :: !REnv.Environ
    -- | Key-value pairs used to index the instrument.  A key may appear more
    -- than once with different values.  Tags are free-form, but there is
    -- a list of standard tags in "Instrument.Tag".
    , forall code. Common code -> [Tag]
common_tags :: ![Tag.Tag]
    -- | So, instrument, tell me about yourself.
    , forall code. Common code -> Doc
common_doc :: !Doc.Doc
    -- | Flags shared with all instruments.
    --
    -- TODO unlike midi flags, these are hardcoded and can't be changed
    -- per-instrument.  I should probably do the same thing as Midi.Patch and
    -- have a Settings which is copied as the default.  But it's a hassle and
    -- I don't need it right now.
    , forall code. Common code -> Set Flag
common_flags :: !(Set Flag)
    , forall code. Common code -> CallMap
common_call_map :: !CallMap
    } deriving (Int -> Common code -> ShowS
[Common code] -> ShowS
Common code -> String
(Int -> Common code -> ShowS)
-> (Common code -> String)
-> ([Common code] -> ShowS)
-> Show (Common code)
forall code. Show code => Int -> Common code -> ShowS
forall code. Show code => [Common code] -> ShowS
forall code. Show code => Common code -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Common code] -> ShowS
$cshowList :: forall code. Show code => [Common code] -> ShowS
show :: Common code -> String
$cshow :: forall code. Show code => Common code -> String
showsPrec :: Int -> Common code -> ShowS
$cshowsPrec :: forall code. Show code => Int -> Common code -> ShowS
Show, (forall a b. (a -> b) -> Common a -> Common b)
-> (forall a b. a -> Common b -> Common a) -> Functor Common
forall a b. a -> Common b -> Common a
forall a b. (a -> b) -> Common a -> Common b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Common b -> Common a
$c<$ :: forall a b. a -> Common b -> Common a
fmap :: forall a b. (a -> b) -> Common a -> Common b
$cfmap :: forall a b. (a -> b) -> Common a -> Common b
Functor)

code :: Common code :-> code
code = (Common code -> code)
-> ((code -> code) -> Common code -> Common code)
-> Common code :-> code
forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens Common code -> code
forall code. Common code -> code
common_code (\code -> code
f Common code
r -> Common code
r { common_code :: code
common_code = code -> code
f (Common code -> code
forall code. Common code -> code
common_code Common code
r) })
environ :: Common code :-> Environ
environ = (Common code -> Environ)
-> ((Environ -> Environ) -> Common code -> Common code)
-> Common code :-> Environ
forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens Common code -> Environ
forall code. Common code -> Environ
common_environ
    (\Environ -> Environ
f Common code
r -> Common code
r { common_environ :: Environ
common_environ = Environ -> Environ
f (Common code -> Environ
forall code. Common code -> Environ
common_environ Common code
r) })
tags :: Common code :-> [Tag]
tags = (Common code -> [Tag])
-> (([Tag] -> [Tag]) -> Common code -> Common code)
-> Common code :-> [Tag]
forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens Common code -> [Tag]
forall code. Common code -> [Tag]
common_tags (\[Tag] -> [Tag]
f Common code
r -> Common code
r { common_tags :: [Tag]
common_tags = [Tag] -> [Tag]
f (Common code -> [Tag]
forall code. Common code -> [Tag]
common_tags Common code
r) })
doc :: Common code :-> Doc
doc = (Common code -> Doc)
-> ((Doc -> Doc) -> Common code -> Common code)
-> Common code :-> Doc
forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens Common code -> Doc
forall code. Common code -> Doc
common_doc (\Doc -> Doc
f Common code
r -> Common code
r { common_doc :: Doc
common_doc = Doc -> Doc
f (Common code -> Doc
forall code. Common code -> Doc
common_doc Common code
r) })
flags :: Common code :-> Set Flag
flags = (Common code -> Set Flag)
-> ((Set Flag -> Set Flag) -> Common code -> Common code)
-> Common code :-> Set Flag
forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens Common code -> Set Flag
forall code. Common code -> Set Flag
common_flags (\Set Flag -> Set Flag
f Common code
r -> Common code
r { common_flags :: Set Flag
common_flags = Set Flag -> Set Flag
f (Common code -> Set Flag
forall code. Common code -> Set Flag
common_flags Common code
r) })
call_map :: Common code :-> CallMap
call_map = (Common code -> CallMap)
-> ((CallMap -> CallMap) -> Common code -> Common code)
-> Common code :-> CallMap
forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens Common code -> CallMap
forall code. Common code -> CallMap
common_call_map
    (\CallMap -> CallMap
f Common code
r -> Common code
r { common_call_map :: CallMap
common_call_map = CallMap -> CallMap
f (Common code -> CallMap
forall code. Common code -> CallMap
common_call_map Common code
r) })

-- | Map attributes to the names of the calls they should map to.  This
-- is used by the integrator to turn score events into UI events.
type CallMap = Map Attrs.Attributes Expr.Symbol

common :: code -> Common code
common :: forall code. code -> Common code
common code
code = Common
    { common_code :: code
common_code = code
code
    , common_environ :: Environ
common_environ = Environ
forall a. Monoid a => a
mempty
    , common_tags :: [Tag]
common_tags = []
    , common_doc :: Doc
common_doc = Doc
""
    , common_flags :: Set Flag
common_flags = Set Flag
forall a. Monoid a => a
mempty
    , common_call_map :: CallMap
common_call_map = CallMap
forall a. Monoid a => a
mempty
    }

instance Pretty code => Pretty (Common code) where
    format :: Common code -> Doc
format (Common code
code Environ
env [Tag]
tags Doc
doc Set Flag
flags CallMap
call_map) =
        Doc -> [(Text, Doc)] -> Doc
Pretty.record Doc
"Instrument"
            [ (Text
"code", code -> Doc
forall a. Pretty a => a -> Doc
Pretty.format code
code)
            , (Text
"restricted_environ", Environ -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Environ
env)
            , (Text
"tags", [Tag] -> Doc
forall a. Pretty a => a -> Doc
Pretty.format [Tag]
tags)
            , (Text
"doc", Doc -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Doc
doc)
            , (Text
"flags", Set Flag -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Set Flag
flags)
            , (Text
"call_map", CallMap -> Doc
forall a. Pretty a => a -> Doc
Pretty.format CallMap
call_map)
            ]

data Flag =
    -- | Patch doesn't pay attention to duration, e.g. percussion.  The UI can
    -- use this to create zero duration events for this instrument.
    Triggered
    deriving (Flag -> Flag -> Bool
(Flag -> Flag -> Bool) -> (Flag -> Flag -> Bool) -> Eq Flag
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Flag -> Flag -> Bool
$c/= :: Flag -> Flag -> Bool
== :: Flag -> Flag -> Bool
$c== :: Flag -> Flag -> Bool
Eq, Eq Flag
Eq Flag
-> (Flag -> Flag -> Ordering)
-> (Flag -> Flag -> Bool)
-> (Flag -> Flag -> Bool)
-> (Flag -> Flag -> Bool)
-> (Flag -> Flag -> Bool)
-> (Flag -> Flag -> Flag)
-> (Flag -> Flag -> Flag)
-> Ord Flag
Flag -> Flag -> Bool
Flag -> Flag -> Ordering
Flag -> Flag -> Flag
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Flag -> Flag -> Flag
$cmin :: Flag -> Flag -> Flag
max :: Flag -> Flag -> Flag
$cmax :: Flag -> Flag -> Flag
>= :: Flag -> Flag -> Bool
$c>= :: Flag -> Flag -> Bool
> :: Flag -> Flag -> Bool
$c> :: Flag -> Flag -> Bool
<= :: Flag -> Flag -> Bool
$c<= :: Flag -> Flag -> Bool
< :: Flag -> Flag -> Bool
$c< :: Flag -> Flag -> Bool
compare :: Flag -> Flag -> Ordering
$ccompare :: Flag -> Flag -> Ordering
Ord, Int -> Flag -> ShowS
[Flag] -> ShowS
Flag -> String
(Int -> Flag -> ShowS)
-> (Flag -> String) -> ([Flag] -> ShowS) -> Show Flag
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Flag] -> ShowS
$cshowList :: [Flag] -> ShowS
show :: Flag -> String
$cshow :: Flag -> String
showsPrec :: Int -> Flag -> ShowS
$cshowsPrec :: Int -> Flag -> ShowS
Show, Int -> Flag
Flag -> Int
Flag -> [Flag]
Flag -> Flag
Flag -> Flag -> [Flag]
Flag -> Flag -> Flag -> [Flag]
(Flag -> Flag)
-> (Flag -> Flag)
-> (Int -> Flag)
-> (Flag -> Int)
-> (Flag -> [Flag])
-> (Flag -> Flag -> [Flag])
-> (Flag -> Flag -> [Flag])
-> (Flag -> Flag -> Flag -> [Flag])
-> Enum Flag
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 :: Flag -> Flag -> Flag -> [Flag]
$cenumFromThenTo :: Flag -> Flag -> Flag -> [Flag]
enumFromTo :: Flag -> Flag -> [Flag]
$cenumFromTo :: Flag -> Flag -> [Flag]
enumFromThen :: Flag -> Flag -> [Flag]
$cenumFromThen :: Flag -> Flag -> [Flag]
enumFrom :: Flag -> [Flag]
$cenumFrom :: Flag -> [Flag]
fromEnum :: Flag -> Int
$cfromEnum :: Flag -> Int
toEnum :: Int -> Flag
$ctoEnum :: Int -> Flag
pred :: Flag -> Flag
$cpred :: Flag -> Flag
succ :: Flag -> Flag
$csucc :: Flag -> Flag
Enum, Flag
Flag -> Flag -> Bounded Flag
forall a. a -> a -> Bounded a
maxBound :: Flag
$cmaxBound :: Flag
minBound :: Flag
$cminBound :: Flag
Bounded)

instance Pretty Flag where pretty :: Flag -> Text
pretty = Flag -> Text
forall a. Show a => a -> Text
showt

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

-- * AttributeMap

{- | This determines what Attributes the instrument can respond to.  Each
    set of Attributes is mapped to a backend-specific value.  The attributes
    are matched by subset in order, so their order gives a priority.

    For example, if @+pizz@ is before @+nv@, then @+pizz+nv@ will map to
    @+pizz@, unless @+pizz+nv@ exists.  The idea is that more specific or
    more perceptually important attributes go first.  Since pizz vs. arco
    is a much more obvious distinction than vibrato vs. nv, if you say
    everything is nv but some notes are also pizz, chances are you want those
    notes to get pizz even if there isn't a specifically nv pizz variant.

    This also means that if a previous attr is a subset of a later one, the
    later one will never be selected.  'overlapping_attributes' will check for
    that, but normally you use a constructor that calls 'sort_attributes' to
    make sure that can't happen.
-}
newtype AttributeMap a = AttributeMap [(Attrs.Attributes, a)]
    deriving (AttributeMap a -> AttributeMap a -> Bool
(AttributeMap a -> AttributeMap a -> Bool)
-> (AttributeMap a -> AttributeMap a -> Bool)
-> Eq (AttributeMap a)
forall a. Eq a => AttributeMap a -> AttributeMap a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AttributeMap a -> AttributeMap a -> Bool
$c/= :: forall a. Eq a => AttributeMap a -> AttributeMap a -> Bool
== :: AttributeMap a -> AttributeMap a -> Bool
$c== :: forall a. Eq a => AttributeMap a -> AttributeMap a -> Bool
Eq, Int -> AttributeMap a -> ShowS
[AttributeMap a] -> ShowS
AttributeMap a -> String
(Int -> AttributeMap a -> ShowS)
-> (AttributeMap a -> String)
-> ([AttributeMap a] -> ShowS)
-> Show (AttributeMap a)
forall a. Show a => Int -> AttributeMap a -> ShowS
forall a. Show a => [AttributeMap a] -> ShowS
forall a. Show a => AttributeMap a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AttributeMap a] -> ShowS
$cshowList :: forall a. Show a => [AttributeMap a] -> ShowS
show :: AttributeMap a -> String
$cshow :: forall a. Show a => AttributeMap a -> String
showsPrec :: Int -> AttributeMap a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> AttributeMap a -> ShowS
Show, [AttributeMap a] -> Doc
AttributeMap a -> Text
AttributeMap a -> Doc
(AttributeMap a -> Text)
-> (AttributeMap a -> Doc)
-> ([AttributeMap a] -> Doc)
-> Pretty (AttributeMap a)
forall a. Pretty a => [AttributeMap a] -> Doc
forall a. Pretty a => AttributeMap a -> Text
forall a. Pretty a => AttributeMap a -> Doc
forall a. (a -> Text) -> (a -> Doc) -> ([a] -> Doc) -> Pretty a
formatList :: [AttributeMap a] -> Doc
$cformatList :: forall a. Pretty a => [AttributeMap a] -> Doc
format :: AttributeMap a -> Doc
$cformat :: forall a. Pretty a => AttributeMap a -> Doc
pretty :: AttributeMap a -> Text
$cpretty :: forall a. Pretty a => AttributeMap a -> Text
Pretty, (forall a b. (a -> b) -> AttributeMap a -> AttributeMap b)
-> (forall a b. a -> AttributeMap b -> AttributeMap a)
-> Functor AttributeMap
forall a b. a -> AttributeMap b -> AttributeMap a
forall a b. (a -> b) -> AttributeMap a -> AttributeMap b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> AttributeMap b -> AttributeMap a
$c<$ :: forall a b. a -> AttributeMap b -> AttributeMap a
fmap :: forall a b. (a -> b) -> AttributeMap a -> AttributeMap b
$cfmap :: forall a b. (a -> b) -> AttributeMap a -> AttributeMap b
Functor, Get (AttributeMap a)
Putter (AttributeMap a)
Putter (AttributeMap a)
-> Get (AttributeMap a) -> Serialize (AttributeMap a)
forall a. Serialize a => Get (AttributeMap a)
forall a. Serialize a => Putter (AttributeMap a)
forall a. Putter a -> Get a -> Serialize a
get :: Get (AttributeMap a)
$cget :: forall a. Serialize a => Get (AttributeMap a)
put :: Putter (AttributeMap a)
$cput :: forall a. Serialize a => Putter (AttributeMap a)
Serialize.Serialize)

instance Semigroup (AttributeMap a) where
    AttributeMap [(Attributes, a)]
as <> :: AttributeMap a -> AttributeMap a -> AttributeMap a
<> AttributeMap [(Attributes, a)]
bs =
        [(Attributes, a)] -> AttributeMap a
forall a. [(Attributes, a)] -> AttributeMap a
AttributeMap ([(Attributes, a)] -> AttributeMap a)
-> [(Attributes, a)] -> AttributeMap a
forall a b. (a -> b) -> a -> b
$ [(Attributes, a)] -> [(Attributes, a)]
forall a. [(Attributes, a)] -> [(Attributes, a)]
sort_attributes ([(Attributes, a)]
as [(Attributes, a)] -> [(Attributes, a)] -> [(Attributes, a)]
forall a. Semigroup a => a -> a -> a
<> [(Attributes, a)]
bs)

instance Monoid (AttributeMap a) where
    mempty :: AttributeMap a
mempty = [(Attributes, a)] -> AttributeMap a
forall a. [(Attributes, a)] -> AttributeMap a
AttributeMap []
    mappend :: AttributeMap a -> AttributeMap a -> AttributeMap a
mappend = AttributeMap a -> AttributeMap a -> AttributeMap a
forall a. Semigroup a => a -> a -> a
(<>)

attribute_map :: [(Attrs.Attributes, a)] -> AttributeMap a
attribute_map :: forall a. [(Attributes, a)] -> AttributeMap a
attribute_map = [(Attributes, a)] -> AttributeMap a
forall a. [(Attributes, a)] -> AttributeMap a
AttributeMap ([(Attributes, a)] -> AttributeMap a)
-> ([(Attributes, a)] -> [(Attributes, a)])
-> [(Attributes, a)]
-> AttributeMap a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Attributes, a)] -> [(Attributes, a)]
forall a. [(Attributes, a)] -> [(Attributes, a)]
sort_attributes

mapped_attributes :: AttributeMap a -> [Attrs.Attributes]
mapped_attributes :: forall a. AttributeMap a -> [Attributes]
mapped_attributes (AttributeMap [(Attributes, a)]
table) = ((Attributes, a) -> Attributes)
-> [(Attributes, a)] -> [Attributes]
forall a b. (a -> b) -> [a] -> [b]
map (Attributes, a) -> Attributes
forall a b. (a, b) -> a
fst [(Attributes, a)]
table

attribute_vals :: AttributeMap a -> [a]
attribute_vals :: forall a. AttributeMap a -> [a]
attribute_vals (AttributeMap [(Attributes, a)]
table) = ((Attributes, a) -> a) -> [(Attributes, a)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (Attributes, a) -> a
forall a b. (a, b) -> b
snd [(Attributes, a)]
table

-- | Look up the value as described in 'AttributeMap'.
lookup_attributes :: Attrs.Attributes -> AttributeMap a
    -> Maybe (Attrs.Attributes, a)
lookup_attributes :: forall a. Attributes -> AttributeMap a -> Maybe (Attributes, a)
lookup_attributes Attributes
attrs (AttributeMap [(Attributes, a)]
table) =
    ((Attributes, a) -> Bool)
-> [(Attributes, a)] -> Maybe (Attributes, a)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find ((Attributes
attrs `Attrs.contain`) (Attributes -> Bool)
-> ((Attributes, a) -> Attributes) -> (Attributes, a) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Attributes, a) -> Attributes
forall a b. (a, b) -> a
fst) [(Attributes, a)]
table

-- | Figured out if any attributes shadow other attributes.  I think this
-- shouldn't happen if you called 'sort_attributes', or used any of the
-- constructors other than 'AttributeMap'.
overlapping_attributes :: AttributeMap a -> [Text]
overlapping_attributes :: forall a. AttributeMap a -> [Text]
overlapping_attributes (AttributeMap [(Attributes, a)]
table) =
    [Maybe Text] -> [Text]
forall a. [Maybe a] -> [a]
Maybe.catMaybes ([Maybe Text] -> [Text]) -> [Maybe Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ ([Attributes] -> Attributes -> Maybe Text)
-> [[Attributes]] -> [Attributes] -> [Maybe Text]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith [Attributes] -> Attributes -> Maybe Text
forall {t :: * -> *}.
Foldable t =>
t Attributes -> Attributes -> Maybe Text
check ([Attributes] -> [[Attributes]]
forall a. [a] -> [[a]]
List.inits [Attributes]
attrs) [Attributes]
attrs
    where
    attrs :: [Attributes]
attrs = ((Attributes, a) -> Attributes)
-> [(Attributes, a)] -> [Attributes]
forall a b. (a -> b) -> [a] -> [b]
map (Attributes, a) -> Attributes
forall a b. (a, b) -> a
fst [(Attributes, a)]
table
    check :: t Attributes -> Attributes -> Maybe Text
check t Attributes
prevs Attributes
attr = case (Attributes -> Bool) -> t Attributes -> Maybe Attributes
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find (Attributes -> Attributes -> Bool
Attrs.contain Attributes
attr) t Attributes
prevs of
        Just Attributes
other_attr -> Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text
"attrs "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Attributes -> Text
forall a. ShowVal a => a -> Text
ShowVal.show_val Attributes
attr Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" shadowed by "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Attributes -> Text
forall a. ShowVal a => a -> Text
ShowVal.show_val Attributes
other_attr
        Maybe Attributes
Nothing -> Maybe Text
forall a. Maybe a
Nothing

-- | 'lookup_attributes' looks for the first subset, which means that a smaller
-- set of attributes can shadow a larger set.  Since it's annoying to have to
-- worry about order, sort larger sets to the back.
--
-- The sort is stable, so it shouldn't destroy the priority implicit in the
-- order.
sort_attributes :: [(Attrs.Attributes, a)] -> [(Attrs.Attributes, a)]
sort_attributes :: forall a. [(Attributes, a)] -> [(Attributes, a)]
sort_attributes = ((Attributes, a) -> Int) -> [(Attributes, a)] -> [(Attributes, a)]
forall k a. Ord k => (a -> k) -> [a] -> [a]
Seq.sort_on (\(Attributes
a, a
_) -> - Set Text -> Int
forall a. Set a -> Int
Set.size (Attributes -> Set Text
Attrs.to_set Attributes
a))


-- * Config

-- | Configuration for a specific allocation of an instrument in a specific
-- score.
data Config = Config {
    -- | This is a local version of 'common_environ'.  Overlayed on the
    -- instrument config 'common_environ'.
    Config -> Environ
config_environ :: !REnv.Environ
    -- | This is the control equivalent to 'config_environ'.  These
    -- controls are merged using their default mergers in the note call.
    -- Being in the note call means that the merge should only happen once.
    -- 'config_environ', on the other hand, is applied when the instrument
    -- comes into scope, which should be safe, since merging the environ is
    -- idempotent.
    --
    -- This can be useful to set a per-instrument transposition, or dynamic
    -- level.
    , Config -> ControlValMap
config_controls :: !ScoreT.ControlValMap
    -- | If true, this instrument is filtered out prior to playing.
    , Config -> Bool
config_mute :: !Bool
    -- | If any instrument is soloed, all instruments except soloed ones are
    -- filtered out prior to playing.
    , Config -> Bool
config_solo :: !Bool
    } deriving (Config -> Config -> Bool
(Config -> Config -> Bool)
-> (Config -> Config -> Bool) -> Eq Config
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Config -> Config -> Bool
$c/= :: Config -> Config -> Bool
== :: Config -> Config -> Bool
$c== :: Config -> Config -> Bool
Eq, Int -> Config -> ShowS
[Config] -> ShowS
Config -> String
(Int -> Config -> ShowS)
-> (Config -> String) -> ([Config] -> ShowS) -> Show Config
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Config] -> ShowS
$cshowList :: [Config] -> ShowS
show :: Config -> String
$cshow :: Config -> String
showsPrec :: Int -> Config -> ShowS
$cshowsPrec :: Int -> Config -> ShowS
Show)

empty_config :: Config
empty_config :: Config
empty_config = Config
    { config_environ :: Environ
config_environ = Environ
forall a. Monoid a => a
mempty
    , config_controls :: ControlValMap
config_controls = ControlValMap
forall a. Monoid a => a
mempty
    , config_mute :: Bool
config_mute = Bool
False
    , config_solo :: Bool
config_solo = Bool
False
    }

cenviron :: Config :-> Environ
cenviron = (Config -> Environ)
-> ((Environ -> Environ) -> Config -> Config) -> Config :-> Environ
forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens Config -> Environ
config_environ
    (\Environ -> Environ
f Config
r -> Config
r { config_environ :: Environ
config_environ = Environ -> Environ
f (Config -> Environ
config_environ Config
r) })
controls :: Config :-> ControlValMap
controls = (Config -> ControlValMap)
-> ((ControlValMap -> ControlValMap) -> Config -> Config)
-> Config :-> ControlValMap
forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens Config -> ControlValMap
config_controls
    (\ControlValMap -> ControlValMap
f Config
r -> Config
r { config_controls :: ControlValMap
config_controls = ControlValMap -> ControlValMap
f (Config -> ControlValMap
config_controls Config
r) })
mute :: Config :-> Bool
mute = (Config -> Bool)
-> ((Bool -> Bool) -> Config -> Config) -> Config :-> Bool
forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens Config -> Bool
config_mute
    (\Bool -> Bool
f Config
r -> Config
r { config_mute :: Bool
config_mute = Bool -> Bool
f (Config -> Bool
config_mute Config
r) })
solo :: Config :-> Bool
solo = (Config -> Bool)
-> ((Bool -> Bool) -> Config -> Config) -> Config :-> Bool
forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens Config -> Bool
config_solo
    (\Bool -> Bool
f Config
r -> Config
r { config_solo :: Bool
config_solo = Bool -> Bool
f (Config -> Bool
config_solo Config
r) })

instance Pretty Config where
    format :: Config -> Doc
format (Config Environ
environ ControlValMap
controls Bool
mute Bool
solo) = Doc -> [(Text, Doc)] -> Doc
Pretty.record Doc
"Config"
        [ (Text
"environ", Environ -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Environ
environ)
        , (Text
"controls", ControlValMap -> Doc
forall a. Pretty a => a -> Doc
Pretty.format ControlValMap
controls)
        , (Text
"mute", Bool -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Bool
mute)
        , (Text
"solo", Bool -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Bool
solo)
        ]

add_cenviron :: REnv.ToVal a => EnvKey.Key -> a
    -> Config -> Config
add_cenviron :: forall a. ToVal a => Text -> a -> Config -> Config
add_cenviron Text
key a
val = Config :-> Environ
cenviron (Config :-> Environ) -> (Environ -> Environ) -> Config -> Config
forall f a. Lens f a -> (a -> a) -> f -> f
%= ([(Text, Val)] -> Environ
REnv.from_list [(Text
key, Val
v)] <>)
    where v :: Val
v = a -> Val
forall a. ToVal a => a -> Val
REnv.to_val a
val