-- Copyright 2021 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 Perform.Sc.PatchDb (load_synth, normalize_patches) where
import qualified Control.Monad.Except as Except
import qualified Data.ByteString as ByteString
import qualified Data.Either as Either
import qualified Data.Map as Map

import qualified System.FilePath as FilePath
import           System.FilePath ((</>))
import qualified Vivid.SC.SynthDef.Literally as Literally

import qualified Util.Exceptions as Exceptions
import qualified Util.Files as Files
import qualified Util.Log as Log
import qualified Util.Lists as Lists
import qualified Util.Texts as Texts

import qualified App.Config as Config
import qualified App.Path as Path
import qualified Cmd.Cmd as Cmd
import qualified Derive.ScoreT as ScoreT
import qualified Instrument.Common as Common
import qualified Instrument.Inst as Inst
import qualified Perform.Sc.Note as Note
import qualified Perform.Sc.Patch as Patch

import           Global


type PatchDb = Map Note.PatchName Patch.Patch

c_gate :: ScoreT.Control
c_gate :: Control
c_gate = SynthName -> Control
ScoreT.Control SynthName
"gate"

-- * load

load_synth :: Path.AppDir -> IO (Maybe (Inst.SynthDecl Cmd.InstrumentCode))
load_synth :: AppDir -> IO (Maybe (SynthDecl InstrumentCode))
load_synth AppDir
app_dir = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PatchDb -> SynthDecl InstrumentCode
synth forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AppDir -> IO (Maybe PatchDb)
load AppDir
app_dir

synth :: PatchDb -> Inst.SynthDecl Cmd.InstrumentCode
synth :: PatchDb -> SynthDecl InstrumentCode
synth PatchDb
patches = forall code.
SynthName
-> SynthName -> [(SynthName, Inst code)] -> SynthDecl code
Inst.SynthDecl SynthName
"sc" SynthName
"supercollider" forall a b. (a -> b) -> a -> b
$
    forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap forall a. Textlike a => a -> SynthName
Texts.toText Patch -> Inst InstrumentCode
make) (forall k a. Map k a -> [(k, a)]
Map.toList PatchDb
patches)
    where
    make :: Patch -> Inst InstrumentCode
make Patch
patch = Inst.Inst
        { inst_backend :: Backend
inst_backend = Patch -> Backend
Inst.Sc Patch
patch
        , inst_common :: Common InstrumentCode
inst_common = forall code. code -> Common code
Common.common InstrumentCode
Cmd.empty_code
        }

load :: Path.AppDir -> IO (Maybe PatchDb)
load :: AppDir -> IO (Maybe PatchDb)
load AppDir
app_dir = String -> IO (Maybe PatchDb)
load_dir (AppDir -> Relative -> String
Path.to_absolute AppDir
app_dir Relative
Config.sc_dir)

load_dir :: FilePath -> IO (Maybe PatchDb)
load_dir :: String -> IO (Maybe PatchDb)
load_dir String
dir = forall a. IO a -> IO (Maybe a)
Exceptions.ignoreEnoent (String -> IO [String]
Files.list String
dir) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe [String]
Nothing -> do
        forall (m :: * -> *). (Stack, LogMonad m) => SynthName -> m ()
Log.notice forall a b. (a -> b) -> a -> b
$ SynthName
"no supercollider patch dir: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> SynthName
showt String
dir
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    Just [String]
fnames -> do
        ([SynthName]
errors, [PatchDb]
patches) <- forall a b. [Either a b] -> ([a], [b])
Either.partitionEithers forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> IO (Either SynthName PatchDb)
load_file [String]
fnames
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *). (Stack, LogMonad m) => SynthName -> m ()
Log.warn [SynthName]
errors
        -- If you ran normalize_patches, there should be no collisions, since
        -- the filesystem disallows them.
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions [PatchDb]
patches

load_file :: FilePath -> IO (Either Text PatchDb)
load_file :: String -> IO (Either SynthName PatchDb)
load_file String
fname =
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (String -> SynthName
txt forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
prefix<>)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> PatchName -> Either String PatchDb
parse String
fname) forall a b. (a -> b) -> a -> b
$ String -> IO PatchName
ByteString.readFile String
fname
    where prefix :: String
prefix = String
fname forall a. Semigroup a => a -> a -> a
<> String
": "

parse :: FilePath -> ByteString.ByteString -> Either String PatchDb
parse :: String -> PatchName -> Either String PatchDb
parse String
fname PatchName
bytes = do
    Literally.SynthDefFile [LiteralSynthDef]
defs <- PatchName -> Either String SynthDefFile
Literally.decodeSynthDefFile PatchName
bytes
    forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [a] -> [b] -> [(a, b)]
zip (forall a b. (a -> b) -> [a] -> [b]
map LiteralSynthDef -> PatchName
Literally._synthDefName [LiteralSynthDef]
defs) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String -> LiteralSynthDef -> Either String Patch
convert String
fname) [LiteralSynthDef]
defs

convert :: FilePath -> Literally.LiteralSynthDef -> Either String Patch.Patch
convert :: String -> LiteralSynthDef -> Either String Patch
convert String
fname LiteralSynthDef
def = do
    ControlId
gate_id <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"no 'gate' control: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> String
prettys Map Control ControlId
controls) forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
        forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Control
c_gate Map Control ControlId
controls
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ControlId
gate_id forall a. Eq a => a -> a -> Bool
== ControlId
Note.gate_id) forall a b. (a -> b) -> a -> b
$
        forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"gate control ID should be " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> String
prettys ControlId
Note.gate_id forall a. Semigroup a => a -> a -> a
<> String
", was "
            forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> String
prettys ControlId
gate_id
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Patch.Patch
        { name :: PatchName
name = LiteralSynthDef -> PatchName
Literally._synthDefName LiteralSynthDef
def
        , filename :: String
filename = String
fname
        , controls :: Map Control ControlId
controls = forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Control
c_gate Map Control ControlId
controls
        }
    where
    controls :: Map Control ControlId
controls = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
        [ (SynthName -> Control
ScoreT.Control (forall a. Textlike a => a -> SynthName
Texts.toText PatchName
name), Int32 -> ControlId
Note.ControlId Int32
ix)
        | Literally.ParamName PatchName
name Int32
ix <- LiteralSynthDef -> [ParamName]
Literally._synthDefParamNames LiteralSynthDef
def
        ]


-- * normalize

-- | Process a directory of .scsyndef patches to validate and make names
-- consistent with filenames.  Call from ghci.
normalize_patches :: FilePath -> FilePath -> IO ()
normalize_patches :: String -> String -> IO ()
normalize_patches String
in_dir String
out_dir = do
    [String]
fnames <- String -> IO [String]
Files.list String
in_dir
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [String]
fnames forall a b. (a -> b) -> a -> b
$ \String
fname -> String -> String -> IO (Either String ())
normalize_patch String
out_dir String
fname forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left String
err -> String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
fname forall a. Semigroup a => a -> a -> a
<> String
": " forall a. Semigroup a => a -> a -> a
<> String
err
        Right () -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

normalize_patch :: FilePath -> FilePath -> IO (Either String ())
normalize_patch :: String -> String -> IO (Either String ())
normalize_patch String
out_dir String
fname = forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
Except.runExceptT forall a b. (a -> b) -> a -> b
$ do
    Literally.SynthDefFile [LiteralSynthDef]
defs <- forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
tryRight forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatchName -> Either String SynthDefFile
Literally.decodeSynthDefFile
        forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO PatchName
ByteString.readFile String
fname)
    case [LiteralSynthDef]
defs of
        [LiteralSynthDef
def] -> String -> LiteralSynthDef -> ExceptT String IO ()
fix String
"" LiteralSynthDef
def
        [LiteralSynthDef]
defs -> forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry String -> LiteralSynthDef -> ExceptT String IO ()
fix) forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip (forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> String
show [Integer
1..]) [LiteralSynthDef]
defs
    where
    fix :: String -> LiteralSynthDef -> ExceptT String IO ()
fix String
suffix LiteralSynthDef
def = do
        Patch
_ <- forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
tryRight forall a b. (a -> b) -> a -> b
$ String -> LiteralSynthDef -> Either String Patch
convert String
fname LiteralSynthDef
def
        let old_name :: PatchName
old_name = LiteralSynthDef -> PatchName
Literally._synthDefName LiteralSynthDef
def
        let fixed :: LiteralSynthDef
fixed = LiteralSynthDef
def { _synthDefName :: PatchName
Literally._synthDefName = forall a. Textlike a => a -> PatchName
Texts.toByteString String
name }
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PatchName
old_name forall a. Eq a => a -> a -> Bool
/= forall a. Textlike a => a -> PatchName
Texts.toByteString String
name) forall a b. (a -> b) -> a -> b
$
            String -> ExceptT String IO ()
put forall a b. (a -> b) -> a -> b
$ String
"renamed " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show PatchName
old_name forall a. Semigroup a => a -> a -> a
<> String
" -> " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show String
name
        let out_fname :: String
out_fname = String
out_dir String -> String -> String
</> String
name forall a. Semigroup a => a -> a -> a
<> String
suffix forall a. Semigroup a => a -> a -> a
<> String
".scsyndef"
        String -> ExceptT String IO ()
put forall a b. (a -> b) -> a -> b
$ String
fname forall a. Semigroup a => a -> a -> a
<> String
" written to " forall a. Semigroup a => a -> a -> a
<> String
out_fname
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> PatchName -> IO ()
ByteString.writeFile String
out_fname
            (LiteralSynthDef -> PatchName
Literally.encodeLiteralSynthDef LiteralSynthDef
fixed)
    name :: String
name = forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a. Eq a => [a] -> [a] -> ([a], Bool)
Lists.dropSuffix String
".scsyndef" forall a b. (a -> b) -> a -> b
$ String -> String
FilePath.takeFileName String
fname
    put :: String -> ExceptT String IO ()
put = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
putStrLn