-- 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.Lists as Lists
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
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 -> 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 = forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens forall code. Common code -> code
common_code (\code -> code
f Common code
r -> Common code
r { common_code :: code
common_code = code -> code
f (forall code. Common code -> code
common_code Common code
r) })
environ :: Common code :-> Environ
environ = forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens forall code. Common code -> Environ
common_environ
    (\Environ -> Environ
f Common code
r -> Common code
r { common_environ :: Environ
common_environ = Environ -> Environ
f (forall code. Common code -> Environ
common_environ Common code
r) })
tags :: Common code :-> [Tag]
tags = forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens forall code. Common code -> [Tag]
common_tags (\[Tag] -> [Tag]
f Common code
r -> Common code
r { common_tags :: [Tag]
common_tags = [Tag] -> [Tag]
f (forall code. Common code -> [Tag]
common_tags Common code
r) })
doc :: Common code :-> Doc
doc = forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens forall code. Common code -> Doc
common_doc (\Doc -> Doc
f Common code
r -> Common code
r { common_doc :: Doc
common_doc = Doc -> Doc
f (forall code. Common code -> Doc
common_doc Common code
r) })
flags :: Common code :-> Set Flag
flags = forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens 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 (forall code. Common code -> Set Flag
common_flags Common code
r) })
call_map :: Common code :-> CallMap
call_map = forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens 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 (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 = forall a. Monoid a => a
mempty
    , common_tags :: [Tag]
common_tags = []
    , common_doc :: Doc
common_doc = Doc
""
    , common_flags :: Set Flag
common_flags = forall a. Monoid a => a
mempty
    , common_call_map :: CallMap
common_call_map = 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", forall a. Pretty a => a -> Doc
Pretty.format code
code)
            , (Text
"restricted_environ", forall a. Pretty a => a -> Doc
Pretty.format Environ
env)
            , (Text
"tags", forall a. Pretty a => a -> Doc
Pretty.format [Tag]
tags)
            , (Text
"doc", forall a. Pretty a => a -> Doc
Pretty.format Doc
doc)
            , (Text
"flags", forall a. Pretty a => a -> Doc
Pretty.format Set Flag
flags)
            , (Text
"call_map", 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
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
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
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]
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
forall a. a -> a -> Bounded a
maxBound :: Flag
$cmaxBound :: Flag
minBound :: Flag
$cminBound :: Flag
Bounded)

instance Pretty Flag where pretty :: Flag -> Text
pretty = 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 =
    forall {code}. Common code :-> Environ
environ forall f a. Lens f a -> (a -> a) -> f -> f
%= ([(Text, Val)] -> Environ
REnv.from_list [(Text
key, 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
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
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
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 -> 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)
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 =
        forall a. [(Attributes, a)] -> AttributeMap a
AttributeMap forall a b. (a -> b) -> a -> b
$ forall a. [(Attributes, a)] -> [(Attributes, a)]
sort_attributes ([(Attributes, a)]
as forall a. Semigroup a => a -> a -> a
<> [(Attributes, a)]
bs)

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

attribute_map :: [(Attrs.Attributes, a)] -> AttributeMap a
attribute_map :: forall a. [(Attributes, a)] -> AttributeMap a
attribute_map = forall a. [(Attributes, a)] -> AttributeMap a
AttributeMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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) = forall a b. (a -> b) -> [a] -> [b]
map 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) = forall a b. (a -> b) -> [a] -> [b]
map 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) =
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find ((Attributes
attrs `Attrs.contain`) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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) =
    forall a. [Maybe a] -> [a]
Maybe.catMaybes forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall {t :: * -> *}.
Foldable t =>
t Attributes -> Attributes -> Maybe Text
check (forall a. [a] -> [[a]]
List.inits [Attributes]
attrs) [Attributes]
attrs
    where
    attrs :: [Attributes]
attrs = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Attributes, a)]
table
    check :: t Attributes -> Attributes -> Maybe Text
check t Attributes
prevs Attributes
attr = case 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 -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text
"attrs "
            forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Text
ShowVal.show_val Attributes
attr forall a. Semigroup a => a -> a -> a
<> Text
" shadowed by "
            forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Text
ShowVal.show_val Attributes
other_attr
        Maybe Attributes
Nothing -> 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 = forall k a. Ord k => (a -> k) -> [a] -> [a]
Lists.sortOn (\(Attributes
a, a
_) -> - 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Config -> Config -> Bool
$c/= :: Config -> Config -> Bool
== :: Config -> Config -> Bool
$c== :: Config -> Config -> Bool
Eq, Int -> Config -> ShowS
[Config] -> ShowS
Config -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Config] -> ShowS
$cshowList :: [Config] -> ShowS
show :: Config -> String
$cshow :: Config -> String
showsPrec :: Int -> Config -> ShowS
$cshowsPrec :: Int -> Config -> ShowS
Show)

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

cenviron :: Config :-> Environ
cenviron = 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 = 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 = 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 = 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", forall a. Pretty a => a -> Doc
Pretty.format Environ
environ)
        , (Text
"controls", forall a. Pretty a => a -> Doc
Pretty.format ControlValMap
controls)
        , (Text
"mute", forall a. Pretty a => a -> Doc
Pretty.format Bool
mute)
        , (Text
"solo", 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 forall f a. Lens f a -> (a -> a) -> f -> f
%= ([(Text, Val)] -> Environ
REnv.from_list [(Text
key, Val
v)] <>)
    where v :: Val
v = forall a. ToVal a => a -> Val
REnv.to_val a
val