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

module Synth.Sampler.Patch where
import qualified Control.Monad.Except as Except
import qualified Control.Monad.Identity as Identity
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Set as Set

import qualified Util.Log as Log
import qualified Util.Maps as Maps
import qualified Util.Seq as Seq

import qualified Cmd.Instrument.ImInst as ImInst
import qualified Perform.Im.Patch as Im.Patch
import qualified Perform.Pitch as Pitch
import qualified Synth.Sampler.Sample as Sample
import qualified Synth.Shared.Control as Control
import qualified Synth.Shared.Note as Note
import qualified Synth.Shared.Signal as Signal

import           Global


db :: FilePath -> [Patch] -> Db
db :: FilePath -> [Patch] -> Db
db FilePath
rootDir [Patch]
patches = Db
    { _rootDir :: FilePath
_rootDir = FilePath
rootDir
    , _patches :: Map Text Patch
_patches = [(Text, Patch)] -> Map Text Patch
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Text, Patch)] -> Map Text Patch)
-> [(Text, Patch)] -> Map Text Patch
forall a b. (a -> b) -> a -> b
$ (Patch -> Text) -> [Patch] -> [(Text, Patch)]
forall a k. (a -> k) -> [a] -> [(k, a)]
Seq.key_on Patch -> Text
_name [Patch]
patches
    }

data Db = Db {
    -- | Base directory for patches.  Samples are in '_rootDir' / '_dir'.
    Db -> FilePath
_rootDir :: !FilePath
    , Db -> Map Text Patch
_patches :: !(Map Note.PatchName Patch)
    }

lookupPatch :: Note.PatchName -> [Patch] -> Maybe Patch
lookupPatch :: Text -> [Patch] -> Maybe Patch
lookupPatch Text
name = (Patch -> Bool) -> [Patch] -> Maybe Patch
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find ((Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
==Text
name) (Text -> Bool) -> (Patch -> Text) -> Patch -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Patch -> Text
_name)

data Patch = Patch {
    Patch -> Text
_name :: Note.PatchName
    -- | Root dir for samples, relative to '_rootDir'.  This is not the same
    -- as '_name' because multiple patches may share a sample directory.
    , Patch -> FilePath
_dir :: FilePath
    -- | Find a sample.
    , Patch -> Note -> ConvertM Sample
_convert :: Note.Note -> ConvertM Sample.Sample
    , Patch -> [Note] -> [Note]
_preprocess :: [Note.Note] -> [Note.Note]
    , Patch -> Maybe EffectConfig
_effect :: !(Maybe EffectConfig)
    -- | Karya configuration.
    --
    -- Putting code here means that the sampler has to link in a large portion
    -- of karya.  To avoid this I'd have to maintain a separate DB in the
    -- sequencer that matches up by name.  For the moment, linking in the extra
    -- code doesn't seem like a problem.
    , Patch -> Patch
_karyaPatch :: ImInst.Patch
    -- | All samples this patch will read, used to test that they all exist.
    -- Relative to '_dir'.  '_convert' is an arbitrary function, so there's
    -- no way to introspect this out, but most should be created with utilities
    -- that can also fill in the filenames.
    , Patch -> Set FilePath
_allFilenames :: Set FilePath
    }

patch :: Note.PatchName -> Patch
patch :: Text -> Patch
patch Text
name = Patch
    { _name :: Text
_name = Text
name
    , _dir :: FilePath
_dir = Text -> FilePath
untxt Text
name
    , _convert :: Note -> ConvertM Sample
_convert = ConvertM Sample -> Note -> ConvertM Sample
forall a b. a -> b -> a
const (ConvertM Sample -> Note -> ConvertM Sample)
-> ConvertM Sample -> Note -> ConvertM Sample
forall a b. (a -> b) -> a -> b
$ Text -> ConvertM Sample
forall e (m :: * -> *) a. MonadError e m => e -> m a
Except.throwError Text
"not implemented"
    , _preprocess :: [Note] -> [Note]
_preprocess = [Note] -> [Note]
forall a. a -> a
id
    , _effect :: Maybe EffectConfig
_effect = Maybe EffectConfig
forall a. Maybe a
Nothing
    , _karyaPatch :: Patch
_karyaPatch = Patch -> Patch
ImInst.make_patch Patch
Im.Patch.patch
    , _allFilenames :: Set FilePath
_allFilenames = Set FilePath
forall a. Monoid a => a
mempty
    }

patchKarya :: Note.PatchName -> (ImInst.Patch -> ImInst.Patch) -> Patch
patchKarya :: Text -> (Patch -> Patch) -> Patch
patchKarya Text
name Patch -> Patch
setKarya = Patch
    { _name :: Text
_name = Text
name
    , _dir :: FilePath
_dir = Text -> FilePath
untxt Text
name
    , _convert :: Note -> ConvertM Sample
_convert = ConvertM Sample -> Note -> ConvertM Sample
forall a b. a -> b -> a
const (ConvertM Sample -> Note -> ConvertM Sample)
-> ConvertM Sample -> Note -> ConvertM Sample
forall a b. (a -> b) -> a -> b
$ Text -> ConvertM Sample
forall e (m :: * -> *) a. MonadError e m => e -> m a
Except.throwError Text
"not implemented"
    , _preprocess :: [Note] -> [Note]
_preprocess = [Note] -> [Note]
forall a. a -> a
id
    , _effect :: Maybe EffectConfig
_effect = Maybe EffectConfig
forall a. Maybe a
Nothing
    , _karyaPatch :: Patch
_karyaPatch = Patch -> Patch
setKarya (Patch -> Patch) -> Patch -> Patch
forall a b. (a -> b) -> a -> b
$ Patch -> Patch
ImInst.make_patch Patch
Im.Patch.patch
    , _allFilenames :: Set FilePath
_allFilenames = Set FilePath
forall a. Monoid a => a
mempty
    }

-- | Make a simple patch of a single sample.
simple :: Note.PatchName -> Sample.SamplePath -> Pitch.NoteNumber -> Patch
simple :: Text -> FilePath -> NoteNumber -> Patch
simple Text
name FilePath
filename NoteNumber
sampleNn = (Text -> Patch
patch Text
name)
    { _convert :: Note -> ConvertM Sample
_convert = \Note
note -> do
        NoteNumber
pitch <- Text -> Maybe NoteNumber -> LogT (ExceptT Text Identity) NoteNumber
forall e (m :: * -> *) a. MonadError e m => e -> Maybe a -> m a
tryJust Text
"no pitch" (Maybe NoteNumber -> LogT (ExceptT Text Identity) NoteNumber)
-> Maybe NoteNumber -> LogT (ExceptT Text Identity) NoteNumber
forall a b. (a -> b) -> a -> b
$ Note -> Maybe NoteNumber
Note.initialPitch Note
note
        Y
dyn <- Text -> Maybe Y -> LogT (ExceptT Text Identity) Y
forall e (m :: * -> *) a. MonadError e m => e -> Maybe a -> m a
tryJust Text
"no dyn" (Maybe Y -> LogT (ExceptT Text Identity) Y)
-> Maybe Y -> LogT (ExceptT Text Identity) Y
forall a b. (a -> b) -> a -> b
$ Control -> Note -> Maybe Y
Note.initial Control
Control.dynamic Note
note
        Sample -> ConvertM Sample
forall (m :: * -> *) a. Monad m => a -> m a
return (Sample -> ConvertM Sample) -> Sample -> ConvertM Sample
forall a b. (a -> b) -> a -> b
$ (FilePath -> Sample
Sample.make FilePath
filename)
            { envelope :: Signal
Sample.envelope = Y -> Signal
forall {k} (kind :: k). Y -> Signal kind
Signal.constant Y
dyn
            , ratios :: Signal
Sample.ratios = Y -> Signal
forall {k} (kind :: k). Y -> Signal kind
Signal.constant (Y -> Signal) -> Y -> Signal
forall a b. (a -> b) -> a -> b
$
                NoteNumber -> NoteNumber -> Y
Sample.pitchToRatio NoteNumber
sampleNn NoteNumber
pitch
            }
    , _allFilenames :: Set FilePath
_allFilenames = FilePath -> Set FilePath
forall a. a -> Set a
Set.singleton FilePath
filename
    , _karyaPatch :: Patch
_karyaPatch = Patch -> Patch
ImInst.make_patch (Patch -> Patch) -> Patch -> Patch
forall a b. (a -> b) -> a -> b
$ Patch
Im.Patch.patch
        { patch_controls :: Map Control Text
Im.Patch.patch_controls = Map Control Text
Control.supportPitch Map Control Text -> Map Control Text -> Map Control Text
forall a. Semigroup a => a -> a -> a
<> Map Control Text
Control.supportDyn
        }
    }

addCode :: ImInst.Code -> Patch -> Patch
addCode :: Code -> Patch -> Patch
addCode Code
code Patch
patch = Patch
patch
    { _karyaPatch :: Patch
_karyaPatch = Lens Patch Code
ImInst.code Lens Patch Code -> (Code -> Code) -> Patch -> Patch
forall f a. Lens f a -> (a -> a) -> f -> f
%= (Code
code<>) (Patch -> Patch) -> Patch -> Patch
forall a b. (a -> b) -> a -> b
$ Patch -> Patch
_karyaPatch Patch
patch }

type ConvertM a = Log.LogT (Except.ExceptT Error Identity.Identity) a
type Error = Text

convert :: Patch -> Note.Note -> Either Error (Sample.Sample, [Log.Msg])
convert :: Patch -> Note -> Either Text (Sample, [Msg])
convert Patch
patch Note
note =
    (Sample -> Sample) -> (Sample, [Msg]) -> (Sample, [Msg])
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Note -> Sample -> Sample
applyStandardControls Note
note) ((Sample, [Msg]) -> (Sample, [Msg]))
-> Either Text (Sample, [Msg]) -> Either Text (Sample, [Msg])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConvertM Sample -> Either Text (Sample, [Msg])
forall a. ConvertM a -> Either Text (a, [Msg])
runConvert (Patch -> Note -> ConvertM Sample
_convert Patch
patch Note
note)

runConvert :: ConvertM a -> Either Error (a, [Log.Msg])
runConvert :: forall a. ConvertM a -> Either Text (a, [Msg])
runConvert = Identity (Either Text (a, [Msg])) -> Either Text (a, [Msg])
forall a. Identity a -> a
Identity.runIdentity (Identity (Either Text (a, [Msg])) -> Either Text (a, [Msg]))
-> (ConvertM a -> Identity (Either Text (a, [Msg])))
-> ConvertM a
-> Either Text (a, [Msg])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT Text Identity (a, [Msg])
-> Identity (Either Text (a, [Msg]))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
Except.runExceptT (ExceptT Text Identity (a, [Msg])
 -> Identity (Either Text (a, [Msg])))
-> (ConvertM a -> ExceptT Text Identity (a, [Msg]))
-> ConvertM a
-> Identity (Either Text (a, [Msg]))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConvertM a -> ExceptT Text Identity (a, [Msg])
forall (m :: * -> *) a. Monad m => LogT m a -> m (a, [Msg])
Log.run

-- | Apply standard controls that all patches support.
applyStandardControls :: Note.Note -> Sample.Sample -> Sample.Sample
applyStandardControls :: Note -> Sample -> Sample
applyStandardControls Note
note =
    Control -> (Signal -> Sample -> Sample) -> Sample -> Sample
forall {a}. Control -> (Signal -> a -> a) -> a -> a
apply Control
Control.volume (\Signal
sig Sample
sample -> Sample
sample
        { envelope :: Signal
Sample.envelope = Signal -> Signal -> Signal
Signal.sig_multiply Signal
sig (Sample -> Signal
Sample.envelope Sample
sample) })
    (Sample -> Sample) -> (Sample -> Sample) -> Sample -> Sample
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Control -> (Signal -> Sample -> Sample) -> Sample -> Sample
forall {a}. Control -> (Signal -> a -> a) -> a -> a
apply Control
Control.pan (\Signal
sig Sample
sample -> Sample
sample
        { pan :: Signal
Sample.pan = Signal -> Signal -> Signal
Signal.sig_add Signal
sig (Sample -> Signal
Sample.pan Sample
sample) })
    where
    apply :: Control -> (Signal -> a -> a) -> a -> a
apply Control
c Signal -> a -> a
set = (a -> a) -> (Signal -> a -> a) -> Maybe Signal -> a -> a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe a -> a
forall a. a -> a
id Signal -> a -> a
set (Control -> Map Control Signal -> Maybe Signal
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Control
c (Note -> Map Control Signal
Note.controls Note
note))

standardControls :: Map Control.Control Text
standardControls :: Map Control Text
standardControls = [(Control, Text)] -> Map Control Text
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
    [ (Control
Control.volume, Text
"Low level volume, in dB.")
    , (Control
Control.pan, Text
"Pan, where -1 is left, and 1 is right.")
    ]


-- * EffectConfig

data EffectConfig = EffectConfig {
    EffectConfig -> Text
_effectName :: Text
    -- | Map event controls to effect controls.  So if the effect exports
    -- "effect-feedback" and we want to refer to it as "depth", then
    -- ("depth", "effect-feedback").
    , EffectConfig -> Map Control Control
_toEffectControl :: !(Map Control.Control Control.Control)
    } deriving (Int -> EffectConfig -> ShowS
[EffectConfig] -> ShowS
EffectConfig -> FilePath
(Int -> EffectConfig -> ShowS)
-> (EffectConfig -> FilePath)
-> ([EffectConfig] -> ShowS)
-> Show EffectConfig
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [EffectConfig] -> ShowS
$cshowList :: [EffectConfig] -> ShowS
show :: EffectConfig -> FilePath
$cshow :: EffectConfig -> FilePath
showsPrec :: Int -> EffectConfig -> ShowS
$cshowsPrec :: Int -> EffectConfig -> ShowS
Show)

effect :: Text -> EffectConfig
effect :: Text -> EffectConfig
effect Text
name = EffectConfig
    { _effectName :: Text
_effectName = Text
name
    , _toEffectControl :: Map Control Control
_toEffectControl = Map Control Control
forall a. Monoid a => a
mempty
    }

-- | Check that rename sources exist.  Check that renamed controls don't
-- overlap patch controls.
checkControls :: Patch -> Set Control.Control -> EffectConfig -> [Text]
checkControls :: Patch -> Set Control -> EffectConfig -> [Text]
checkControls Patch
patch Set Control
effectControls EffectConfig
effectConfig = [[Text]] -> [Text]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [ Text
"rename sources not in effect: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Set Control -> Text
forall a. Pretty a => a -> Text
pretty Set Control
unknownRenameFrom
      | Bool -> Bool
not (Set Control -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Set Control
unknownRenameFrom)
      ]
    , [ Text
"effect controls overlap with patch: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Set Control -> Text
forall a. Pretty a => a -> Text
pretty Set Control
patchOverlaps
      | Bool -> Bool
not (Set Control -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Set Control
patchOverlaps)
      ]
    ]
    where
    toScoreControl :: Map Control Control
toScoreControl = Map Control Control -> Map Control Control
forall a k. Ord a => Map k a -> Map a k
Maps.invert (Map Control Control -> Map Control Control)
-> Map Control Control -> Map Control Control
forall a b. (a -> b) -> a -> b
$ EffectConfig -> Map Control Control
_toEffectControl EffectConfig
effectConfig
    unknownRenameFrom :: Set Control
unknownRenameFrom =
        Map Control Control -> Set Control
forall k a. Map k a -> Set k
Map.keysSet Map Control Control
toScoreControl Set Control -> Set Control -> Set Control
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set Control
effectControls
    renamed :: Set Control
renamed =
        (Control -> Control) -> Set Control -> Set Control
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (\Control
c -> Control -> Control -> Map Control Control -> Control
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Control
c Control
c Map Control Control
toScoreControl) Set Control
effectControls
    patchOverlaps :: Set Control
patchOverlaps = Set Control -> Set Control -> Set Control
forall a. Ord a => Set a -> Set a -> Set a
Set.intersection Set Control
renamed Set Control
patchControls
    patchControls :: Set Control
patchControls = Map Control Text -> Set Control
forall k a. Map k a -> Set k
Map.keysSet (Map Control Text -> Set Control)
-> Map Control Text -> Set Control
forall a b. (a -> b) -> a -> b
$ Patch -> Map Control Text
Im.Patch.patch_controls (Patch -> Map Control Text) -> Patch -> Map Control Text
forall a b. (a -> b) -> a -> b
$
        Patch -> Patch
ImInst.patch_patch (Patch -> Patch) -> Patch -> Patch
forall a b. (a -> b) -> a -> b
$ Patch -> Patch
_karyaPatch Patch
patch