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

{- | This is called Inst because I already have way too many modules named
    Instrument and I couldn't think of anything better.  TODO think of
    something better.

    The hierarchy, from general to specific goes:

    - 'InstT.Qualified' - global name of an Inst, used to instantiate
    a ScoreTypes.Instrument.

    - 'ScoreTypes.Instrument' - name an instance of an Inst within a score

    - 'Inst' - instrument encompassing all backends.

    - Patch - backend-specific instrument

    Instrument configuration is divided into static (built-in to the instrument)
    and dynamic (configured per score).

    Static configuration starts with 'Inst', and is divided into 'Backend'
    specific and 'Common.Common'.

    Dynamic configuration starts with 'Ui.StateConfig.Allocation' and is also
    divided into 'Ui.StateConfig.Backend' specific and 'Common.Config'.  When
    a new allocation is created, the 'Midi.Patch.patch_defaults' are copied
    to 'Midi.Patch.config_settings'.
-}
module Instrument.Inst (
    -- * Inst
    Inst(..), common, backend, Backend(..), backend_name
    , inst_midi, inst_attributes
    -- * db
    , Db, Synth(..), empty, size, synth_names, synths, lookup_synth, lookup
    , SynthDecl(..), db, merge
    , annotate
) where
import           Prelude hiding (lookup)
import qualified Data.Map as Map

import qualified Util.Lens as Lens
import qualified Util.Maps as Maps
import qualified Util.Num as Num
import qualified Util.Pretty as Pretty

import qualified Derive.Attrs as Attrs
import qualified Instrument.Common as Common
import qualified Instrument.InstT as InstT
import qualified Instrument.Tag as Tag

import qualified Perform.Im.Patch as Im.Patch
import qualified Perform.Midi.Patch as Midi.Patch
import qualified Perform.Sc.Patch as Sc.Patch

import           Global


-- * Inst

data Inst code = Inst {
    forall code. Inst code -> Backend
inst_backend :: !Backend
    , forall code. Inst code -> Common code
inst_common :: !(Common.Common code)
    } deriving (Int -> Inst code -> ShowS
forall code. Show code => Int -> Inst code -> ShowS
forall code. Show code => [Inst code] -> ShowS
forall code. Show code => Inst code -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Inst code] -> ShowS
$cshowList :: forall code. Show code => [Inst code] -> ShowS
show :: Inst code -> String
$cshow :: forall code. Show code => Inst code -> String
showsPrec :: Int -> Inst code -> ShowS
$cshowsPrec :: forall code. Show code => Int -> Inst code -> ShowS
Show)

backend :: Inst code :-> Backend
backend = forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens forall code. Inst code -> Backend
inst_backend
    (\Backend -> Backend
f Inst code
r -> Inst code
r { inst_backend :: Backend
inst_backend = Backend -> Backend
f (forall code. Inst code -> Backend
inst_backend Inst code
r) })
common :: Inst code :-> Common code
common = forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens forall code. Inst code -> Common code
inst_common (\Common code -> Common code
f Inst code
r -> Inst code
r { inst_common :: Common code
inst_common = Common code -> Common code
f (forall code. Inst code -> Common code
inst_common Inst code
r) })

instance Pretty code => Pretty (Inst code) where
    format :: Inst code -> Doc
format (Inst Backend
backend Common code
common) = Doc -> [(Text, Doc)] -> Doc
Pretty.record Doc
"Inst"
        [ (Text
"backend", forall a. Pretty a => a -> Doc
Pretty.format Backend
backend)
        , (Text
"common", forall a. Pretty a => a -> Doc
Pretty.format Common code
common)
        ]

data Backend =
    -- | A Dummy instrument should be resolved to concrete instruments during
    -- derivation.  It includes an error msg show if that doesn't happen.
    Dummy !Text
    | Midi !Midi.Patch.Patch
    | Im !Im.Patch.Patch
    | Sc !Sc.Patch.Patch
    deriving (Int -> Backend -> ShowS
[Backend] -> ShowS
Backend -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Backend] -> ShowS
$cshowList :: [Backend] -> ShowS
show :: Backend -> String
$cshow :: Backend -> String
showsPrec :: Int -> Backend -> ShowS
$cshowsPrec :: Int -> Backend -> ShowS
Show)

instance Pretty Backend where
    format :: Backend -> Doc
format = \case
        Dummy Text
msg -> Doc
"Dummy \"" forall a. Semigroup a => a -> a -> a
<> Text -> Doc
Pretty.text Text
msg forall a. Semigroup a => a -> a -> a
<> Doc
"\""
        Midi Patch
patch -> forall a. Pretty a => a -> Doc
Pretty.format Patch
patch
        Im Patch
patch -> forall a. Pretty a => a -> Doc
Pretty.format Patch
patch
        Sc Patch
patch -> forall a. Pretty a => a -> Doc
Pretty.format Patch
patch

backend_name :: Backend -> Text
backend_name :: Backend -> Text
backend_name = \case
    Dummy {} -> Text
"dummy"
    Midi {} -> Text
"midi"
    Im {} -> Text
"音"
    Sc {} -> Text
"sc"

inst_midi :: Inst code -> Maybe Midi.Patch.Patch
inst_midi :: forall code. Inst code -> Maybe Patch
inst_midi Inst code
inst = case forall code. Inst code -> Backend
inst_backend Inst code
inst of
    Midi Patch
inst -> forall a. a -> Maybe a
Just Patch
inst
    Backend
_ -> forall a. Maybe a
Nothing

inst_attributes :: Inst code -> [Attrs.Attributes]
inst_attributes :: forall code. Inst code -> [Attributes]
inst_attributes Inst code
inst = case forall code. Inst code -> Backend
inst_backend Inst code
inst of
    Dummy {} -> []
    Midi Patch
patch -> forall a. AttributeMap a -> [Attributes]
Common.mapped_attributes forall a b. (a -> b) -> a -> b
$
        Patch -> AttributeMap
Midi.Patch.patch_attribute_map Patch
patch
    Im Patch
patch -> forall a. AttributeMap a -> [Attributes]
Common.mapped_attributes forall a b. (a -> b) -> a -> b
$
        Patch -> AttributeMap
Im.Patch.patch_attribute_map Patch
patch
    Sc Patch
_patch -> []

-- * Db

newtype Db code = Db (Map InstT.SynthName (Synth code))
    deriving (Int -> Db code -> ShowS
forall code. Show code => Int -> Db code -> ShowS
forall code. Show code => [Db code] -> ShowS
forall code. Show code => Db code -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Db code] -> ShowS
$cshowList :: forall code. Show code => [Db code] -> ShowS
show :: Db code -> String
$cshow :: forall code. Show code => Db code -> String
showsPrec :: Int -> Db code -> ShowS
$cshowsPrec :: forall code. Show code => Int -> Db code -> ShowS
Show, [Db code] -> Doc
Db code -> Text
Db code -> Doc
forall code. Pretty code => [Db code] -> Doc
forall code. Pretty code => Db code -> Text
forall code. Pretty code => Db code -> Doc
forall a. (a -> Text) -> (a -> Doc) -> ([a] -> Doc) -> Pretty a
formatList :: [Db code] -> Doc
$cformatList :: forall code. Pretty code => [Db code] -> Doc
format :: Db code -> Doc
$cformat :: forall code. Pretty code => Db code -> Doc
pretty :: Db code -> Text
$cpretty :: forall code. Pretty code => Db code -> Text
Pretty)

data Synth code = Synth {
    -- | Full name, just for documentation.
    forall code. Synth code -> Text
synth_doc :: !Text
    , forall code. Synth code -> Map Text (Inst code)
synth_insts :: !(Map InstT.Name (Inst code))
    } deriving (Int -> Synth code -> ShowS
forall code. Show code => Int -> Synth code -> ShowS
forall code. Show code => [Synth code] -> ShowS
forall code. Show code => Synth code -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Synth code] -> ShowS
$cshowList :: forall code. Show code => [Synth code] -> ShowS
show :: Synth code -> String
$cshow :: forall code. Show code => Synth code -> String
showsPrec :: Int -> Synth code -> ShowS
$cshowsPrec :: forall code. Show code => Int -> Synth code -> ShowS
Show)

insts :: Synth code :-> Map Text (Inst code)
insts = forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens forall code. Synth code -> Map Text (Inst code)
synth_insts (\Map Text (Inst code) -> Map Text (Inst code)
f Synth code
r -> Synth code
r { synth_insts :: Map Text (Inst code)
synth_insts = Map Text (Inst code) -> Map Text (Inst code)
f (forall code. Synth code -> Map Text (Inst code)
synth_insts Synth code
r) })

instance Pretty code => Pretty (Synth code) where
    format :: Synth code -> Doc
format (Synth Text
_ Map Text (Inst code)
insts) = forall a. Pretty a => a -> Doc
Pretty.format Map Text (Inst code)
insts

empty :: Db code
empty :: forall code. Db code
empty = forall code. Map Text (Synth code) -> Db code
Db forall a. Monoid a => a
mempty

-- | Number of 'Inst's in the db.
size :: Db code -> Int
size :: forall code. Db code -> Int
size (Db Map Text (Synth code)
db) = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
Num.sum forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall k a. Map k a -> Int
Map.size forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall code. Synth code -> Map Text (Inst code)
synth_insts) forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [a]
Map.elems Map Text (Synth code)
db

synth_names :: Db code -> [InstT.SynthName]
synth_names :: forall code. Db code -> [Text]
synth_names (Db Map Text (Synth code)
db) = forall k a. Map k a -> [k]
Map.keys Map Text (Synth code)
db

synths :: Db code -> [(InstT.SynthName, Synth code)]
synths :: forall code. Db code -> [(Text, Synth code)]
synths (Db Map Text (Synth code)
db) = forall k a. Map k a -> [(k, a)]
Map.toList Map Text (Synth code)
db

lookup_synth :: InstT.SynthName -> Db code -> Maybe (Synth code)
lookup_synth :: forall code. Text -> Db code -> Maybe (Synth code)
lookup_synth Text
synth (Db Map Text (Synth code)
db) = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
synth Map Text (Synth code)
db

lookup :: InstT.Qualified -> Db code -> Maybe (Inst code)
lookup :: forall code. Qualified -> Db code -> Maybe (Inst code)
lookup (InstT.Qualified Text
synth Text
name) (Db Map Text (Synth code)
db) =
    forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
name forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall code. Synth code -> Map Text (Inst code)
synth_insts forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
synth Map Text (Synth code)
db

-- | Unchecked synth declaration.  'db' will check it for duplicates and other
-- problems.  (name, doc, patches)
data SynthDecl code =
    SynthDecl !InstT.SynthName !Text ![(InstT.Name, Inst code)]
    deriving (Int -> SynthDecl code -> ShowS
forall code. Show code => Int -> SynthDecl code -> ShowS
forall code. Show code => [SynthDecl code] -> ShowS
forall code. Show code => SynthDecl code -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SynthDecl code] -> ShowS
$cshowList :: forall code. Show code => [SynthDecl code] -> ShowS
show :: SynthDecl code -> String
$cshow :: forall code. Show code => SynthDecl code -> String
showsPrec :: Int -> SynthDecl code -> ShowS
$cshowsPrec :: forall code. Show code => Int -> SynthDecl code -> ShowS
Show)

instance Pretty code => Pretty (SynthDecl code) where
    format :: SynthDecl code -> Doc
format (SynthDecl Text
name Text
doc [(Text, Inst code)]
insts) = Doc -> [(Text, Doc)] -> Doc
Pretty.record Doc
"SynthDecl"
        [ (Text
"name", forall a. Pretty a => a -> Doc
Pretty.format Text
name)
        , (Text
"doc", forall a. Pretty a => a -> Doc
Pretty.format Text
doc)
        , (Text
"instruments", forall a. Pretty a => a -> Doc
Pretty.format [(Text, Inst code)]
insts)
        ]

-- | Construct and validate a Db, returning any errors that occurred.
db :: [SynthDecl code] -> (Db code, [Text])
db :: forall code. [SynthDecl code] -> (Db code, [Text])
db [SynthDecl code]
synth_decls = (forall code. Map Text (Synth code) -> Db code
Db Map Text (Synth code)
db, [Text]
synth_errors forall a. [a] -> [a] -> [a]
++ [Text]
inst_errors forall a. [a] -> [a] -> [a]
++ [Text]
validate_errors)
    where
    ([(Text, Synth code)]
inst_maps, [Text]
inst_errors) = forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a b. [(a, b)] -> ([a], [b])
unzip forall a b. (a -> b) -> a -> b
$ do
        SynthDecl Text
synth Text
synth_doc [(Text, Inst code)]
insts <- [SynthDecl code]
synth_decls
        let (Map Text (Inst code)
inst_map, [(Text, Inst code)]
dups) = forall a b. Ord a => [(a, b)] -> (Map a b, [(a, b)])
Maps.unique [(Text, Inst code)]
insts
        let errors :: [Text]
errors =
                [ Text
"duplicate inst: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty (Text -> Text -> Qualified
InstT.Qualified Text
synth Text
name)
                | Text
name <- forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Text, Inst code)]
dups
                ]
        forall (m :: * -> *) a. Monad m => a -> m a
return ((Text
synth, forall code. Text -> Map Text (Inst code) -> Synth code
Synth Text
synth_doc Map Text (Inst code)
inst_map), [Text]
errors)
    (Map Text (Synth code)
db, [(Text, Synth code)]
dups) = forall a b. Ord a => [(a, b)] -> (Map a b, [(a, b)])
Maps.unique [(Text, Synth code)]
inst_maps
    synth_errors :: [Text]
synth_errors = [Text
"duplicate synth: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Text
synth | Text
synth <- forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Text, Synth code)]
dups]
    validate_errors :: [Text]
validate_errors = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ forall a b. (a -> b) -> [a] -> [b]
map ((forall a. Pretty a => a -> Text
pretty (Text -> Text -> Qualified
InstT.Qualified Text
synth Text
name) forall a. Semigroup a => a -> a -> a
<> Text
": ") <>)
            (forall code. Inst code -> [Text]
validate Inst code
inst)
        | SynthDecl Text
synth Text
_ [(Text, Inst code)]
insts <- [SynthDecl code]
synth_decls, (Text
name, Inst code
inst) <- [(Text, Inst code)]
insts
        ]

-- | Return any errors found in the Inst.
validate :: Inst code -> [Text]
validate :: forall code. Inst code -> [Text]
validate Inst code
inst = case forall code. Inst code -> Backend
inst_backend Inst code
inst of
    Dummy {} -> []
    Midi Patch
patch -> forall a. AttributeMap a -> [Text]
Common.overlapping_attributes forall a b. (a -> b) -> a -> b
$
        Patch -> AttributeMap
Midi.Patch.patch_attribute_map Patch
patch
    Im Patch
patch -> forall a. AttributeMap a -> [Text]
Common.overlapping_attributes forall a b. (a -> b) -> a -> b
$
        Patch -> AttributeMap
Im.Patch.patch_attribute_map Patch
patch
    Sc Patch
_patch -> []

-- | Merge the Dbs, and return any duplicate synths.
merge :: Db code -> Db code -> (Db code, [InstT.SynthName])
merge :: forall code. Db code -> Db code -> (Db code, [Text])
merge (Db Map Text (Synth code)
db1) (Db Map Text (Synth code)
db2) = (forall code. Map Text (Synth code) -> Db code
Db Map Text (Synth code)
db, forall k a. Map k a -> [k]
Map.keys Map Text (Synth code)
dups)
    where (Map Text (Synth code)
db, Map Text (Synth code)
dups) = forall k a. Ord k => Map k a -> Map k a -> (Map k a, Map k a)
Maps.uniqueUnion Map Text (Synth code)
db1 Map Text (Synth code)
db2

annotate :: Map InstT.Qualified [Tag.Tag] -> Db code
    -> (Db code, [InstT.Qualified])
annotate :: forall code.
Map Qualified [Tag] -> Db code -> (Db code, [Qualified])
annotate Map Qualified [Tag]
annots Db code
db = forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey forall {code}.
Qualified
-> [Tag] -> (Db code, [Qualified]) -> (Db code, [Qualified])
modify (Db code
db, []) Map Qualified [Tag]
annots
    where
    modify :: Qualified
-> [Tag] -> (Db code, [Qualified]) -> (Db code, [Qualified])
modify qualified :: Qualified
qualified@(InstT.Qualified Text
synth Text
name) [Tag]
tags (Db code
db, [Qualified]
not_found) =
        case forall code.
Text
-> Text -> (Inst code -> Inst code) -> Db code -> Maybe (Db code)
modify_inst Text
synth Text
name (forall {code}. [Tag] -> Inst code -> Inst code
add_tags [Tag]
tags) Db code
db of
            Maybe (Db code)
Nothing -> (Db code
db, Qualified
qualified forall a. a -> [a] -> [a]
: [Qualified]
not_found)
            Just Db code
db -> (Db code
db, [Qualified]
not_found)
    add_tags :: [Tag] -> Inst code -> Inst code
add_tags [Tag]
tags = forall {code}. Inst code :-> Common code
commonforall a b c. Lens a b -> Lens b c -> Lens a c
#forall {code}. Common code :-> [Tag]
Common.tags forall f a. Lens f a -> (a -> a) -> f -> f
%= ([Tag]
tags++)

modify_inst :: InstT.SynthName -> InstT.Name -> (Inst code -> Inst code)
    -> Db code -> Maybe (Db code)
modify_inst :: forall code.
Text
-> Text -> (Inst code -> Inst code) -> Db code -> Maybe (Db code)
modify_inst Text
synth Text
name Inst code -> Inst code
modify (Db Map Text (Synth code)
db) = forall code. Map Text (Synth code) -> Db code
Db forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
    Inst code
inst <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
name forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall code. Synth code -> Map Text (Inst code)
synth_insts forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
synth Map Text (Synth code)
db
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust (forall {code}. Synth code :-> Map Text (Inst code)
insts forall f a. Lens f a -> (a -> a) -> f -> f
%= forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
name (Inst code -> Inst code
modify Inst code
inst)) Text
synth Map Text (Synth code)
db