-- Copyright 2017 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 CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
-- | Shared config to coordinate between the sequencer and im subsystems.
module Synth.Shared.Config where
import qualified Data.Aeson as Aeson
import qualified Data.ByteString.Lazy.Char8 as ByteString.Lazy.Char8
import qualified Data.HashSet as HashSet
import qualified Data.Map as Map
import qualified Data.Maybe as Maybe
import qualified Data.Set as Set
import qualified Data.Text as Text

import qualified GHC.Generics as Generics
import qualified GHC.Stack
import qualified Network.Socket as Socket
import qualified System.Directory as Directory
import qualified System.FilePath as FilePath
import           System.FilePath ((</>))
import qualified System.IO as IO
import qualified System.IO.Unsafe as Unsafe

import qualified Text.Read as Read

import qualified Util.Audio.AudioT as AudioT
import qualified Util.Exceptions as Exceptions
import qualified Util.Lists as Lists
import qualified Util.Log as Log
import qualified Util.Num as Num
import qualified Util.Texts as Texts

import qualified App.Config
import qualified App.Config as Config
import qualified App.Path as Path

import qualified Derive.ScoreT as ScoreT
import qualified Derive.Stack as Stack
import qualified Ui.Id as Id

import           Global
import           Synth.Types

#include "config.h"


-- | Index into the audio chunks for a single instrument render.
-- This is the same as 'Ui.Types.ChunkNum'.
type ChunkNum = Int

data Config = Config {
    -- | All of the data files used by the Im backend are based in this
    -- directory.  Everything in here should be temporary files, used for
    -- communication or caching.
    Config -> [Char]
imDir :: FilePath
    , Config -> Map Text Synth
synths :: Map SynthName Synth
    }
    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, ChunkNum -> Config -> ShowS
[Config] -> ShowS
Config -> [Char]
forall a.
(ChunkNum -> a -> ShowS)
-> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Config] -> ShowS
$cshowList :: [Config] -> ShowS
show :: Config -> [Char]
$cshow :: Config -> [Char]
showsPrec :: ChunkNum -> Config -> ShowS
$cshowsPrec :: ChunkNum -> Config -> ShowS
Show)

getConfig :: IO Config
getConfig :: IO Config
getConfig = AppDir -> Config
config forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO AppDir
Path.get_app_dir

getLogFilename :: String -> IO FilePath
getLogFilename :: [Char] -> IO [Char]
getLogFilename [Char]
name = do
    [Char]
dir <- AppDir -> Relative -> [Char]
Path.to_absolute forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO AppDir
Path.get_app_dir forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Relative
App.Config.log_dir
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Char]
dir [Char] -> ShowS
</> [Char]
name

config :: Path.AppDir -> Config
config :: AppDir -> Config
config AppDir
appDir = Config
    { imDir :: [Char]
imDir = AppDir -> Relative -> [Char]
Path.to_absolute AppDir
appDir Relative
Config.im_dir
    , synths :: Map Text Synth
synths = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
        [ (Text
samplerName, Synth
sampler)
        , (Text
faustName, Synth
faust)
        , (Text
nessName, Synth
ness)
        ]
    }

data Synth = Synth {
    -- | This should uniquely determine the synth, since it becomes the notes
    -- filename.
    Synth -> [Char]
synthName :: !FilePath
    -- | Path to the binary.  Don't run a binary if it's empty.
    , Synth -> [Char]
binary :: !FilePath
    } deriving (Synth -> Synth -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Synth -> Synth -> Bool
$c/= :: Synth -> Synth -> Bool
== :: Synth -> Synth -> Bool
$c== :: Synth -> Synth -> Bool
Eq, ChunkNum -> Synth -> ShowS
[Synth] -> ShowS
Synth -> [Char]
forall a.
(ChunkNum -> a -> ShowS)
-> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Synth] -> ShowS
$cshowList :: [Synth] -> ShowS
show :: Synth -> [Char]
$cshow :: Synth -> [Char]
showsPrec :: ChunkNum -> Synth -> ShowS
$cshowsPrec :: ChunkNum -> Synth -> ShowS
Show)

type SynthName = Text

nessName :: SynthName
nessName :: Text
nessName = Text
"ness"

samplerName :: SynthName
samplerName :: Text
samplerName = Text
"sampler"

sampler :: Synth
sampler :: Synth
sampler = Synth
    { synthName :: [Char]
synthName = [Char]
"sampler"
    , binary :: [Char]
binary = [Char]
"build/opt/sampler-im"
    }

-- | Base directory for sampler patches.
samplerRoot :: Path.Relative
samplerRoot :: Relative
samplerRoot = Relative
Config.data_dir Relative -> Relative -> Relative
Path.</> Relative
"sampler"

-- | This is samplerRoot, but as an absolute path.
--
-- Technically, Path.get_app_dir is in IO, so I can't get an absolute path
-- without IO.  However, I need to put the absolute path in the Thru play msgs
-- (ultimately since play_cache runs with an unknown CWD), and it gets really
-- annoying to try to get a Path.AppDir into the thru function's closure.  So
-- unsafePerformIO it is.  I could probably just put that on app_dir, but this
-- is the only thing that actually needs it.
unsafeSamplerRoot :: FilePath
unsafeSamplerRoot :: [Char]
unsafeSamplerRoot =
    AppDir -> Relative -> [Char]
Path.to_absolute (forall a. IO a -> a
Unsafe.unsafePerformIO IO AppDir
Path.get_app_dir) Relative
samplerRoot
{-# NOINLINE unsafeSamplerRoot #-}

faustName :: SynthName
faustName :: Text
faustName = Text
"faust"

faust :: Synth
faust :: Synth
faust = Synth
    { synthName :: [Char]
synthName = [Char]
"faust"
    , binary :: [Char]
binary = [Char]
"build/opt/faust-im"
    }

ness ::Synth
ness :: Synth
ness = Synth
    { synthName :: [Char]
synthName = [Char]
"ness"
    , binary :: [Char]
binary = [Char]
""
    }

-- | All serialized notes are in im </> notesParentDir.
notesParentDir :: FilePath
notesParentDir :: [Char]
notesParentDir = [Char]
"notes"

-- | All rendered output is in im </> cacheDir.
cacheDir :: FilePath
cacheDir :: [Char]
cacheDir = [Char]
"cache"

-- | All im synths render at this sampling rate, and the sequencer sets the
-- start time by it.
samplingRate :: Int
samplingRate :: ChunkNum
samplingRate = SAMPLING_RATE

type SamplingRate = SAMPLING_RATE

-- | Save an audio chunk and checkpoint in this many frames.
--
-- A smaller size will lead to more checkpoints, which means finer grained
-- caching, but more overhead saving the intermediate states.  So a slower
-- synthesizer with smaller state should use small chunks, fast rendering or
-- large state imply large chunks.  I could in theory adjust this per
-- synthesizer, though currently karya relies on it being constant.
chunkSize :: AudioT.Frames
chunkSize :: Frames
chunkSize = ChunkNum -> Frames
AudioT.Frames forall a b. (a -> b) -> a -> b
$ ChunkNum
samplingRate forall a. Num a => a -> a -> a
* ChunkNum
chunkSeconds

-- | Number of frames in each audio block.  A chunk corresponds to the output
-- file size, and the block is the internal processing size.
--
-- To make sure checkpoint states line up with the file boundaries, this must
-- divide into 'chunkSize'.
blockSize :: AudioT.Frames
blockSize :: Frames
blockSize = Frames
chunkSize forall a. (HasCallStack, Integral a) => a -> a -> a
`Num.assertDiv` Frames
16

chunkSeconds :: Int
chunkSeconds :: ChunkNum
chunkSeconds = CHUNK_SECONDS

-- | play_cache delays play start by this many frames, so MIDI output should
-- also be delayed by this much to match.
--
-- It has to cue up the sample streaming, which means it has to find and
-- seek to the right file.  If playback starts immediately then the first
-- chunk gets cut off, which cuts off note attacks.
startLatency :: AudioT.Frames
startLatency :: Frames
startLatency = START_LATENCY_FRAMES

thruPort :: Socket.PortNumber
thruPort :: PortNumber
thruPort = THRU_PORT

-- * cache files

{- Filenames have to be coordinated between the karya notes output, the
    synth cache output, and the play msg sent to play_cache:

    notes:  im/notes/scorePath/ns/block/synth
    output: im/cache/scorePath/ns/block/inst/###.wav
    play:   scorePath/ns/block, [inst] in mutes
-}

-- | Write serialized notes to this file.
notesFilename :: FilePath -> FilePath
    -- ^ Path to the score, relative to the save dir.  This should uniquely
    -- identify this score.
    -> Id.BlockId -> Synth -> FilePath
notesFilename :: [Char] -> [Char] -> BlockId -> Synth -> [Char]
notesFilename [Char]
imDir [Char]
scorePath BlockId
blockId Synth
synth =
    [Char] -> [Char] -> BlockId -> [Char]
notesDirectory [Char]
imDir [Char]
scorePath BlockId
blockId [Char] -> ShowS
</> Synth -> [Char]
synthName Synth
synth

notesDirectory :: FilePath -> FilePath -> Id.BlockId -> FilePath
notesDirectory :: [Char] -> [Char] -> BlockId -> [Char]
notesDirectory [Char]
imDir [Char]
scorePath BlockId
blockId =
    [Char]
imDir [Char] -> ShowS
</> [Char]
notesParentDir [Char] -> ShowS
</> [Char]
scorePath [Char] -> ShowS
</> forall a. Ident a => a -> [Char]
idFilename BlockId
blockId

-- | Top level output for for a block render.  It will have directories below
-- it for each instrument.
outputDirectory :: FilePath -> FilePath -> Id.BlockId -> FilePath
outputDirectory :: [Char] -> [Char] -> BlockId -> [Char]
outputDirectory [Char]
imDir [Char]
scorePath BlockId
blockId =
    [Char]
imDir [Char] -> ShowS
</> [Char]
cacheDir [Char] -> ShowS
</> [Char]
scorePath [Char] -> ShowS
</> forall a. Ident a => a -> [Char]
idFilename BlockId
blockId

-- | Get the filename for a particular checkpoint.
chunkPath :: FilePath -> FilePath -> Id.BlockId -> ScoreT.Instrument
    -> ChunkNum -> FilePath
chunkPath :: [Char] -> [Char] -> BlockId -> Instrument -> ChunkNum -> [Char]
chunkPath [Char]
imDir [Char]
scorePath BlockId
blockId Instrument
inst ChunkNum
chunknum =
    [Char] -> [Char] -> BlockId -> [Char]
outputDirectory [Char]
imDir [Char]
scorePath BlockId
blockId
        [Char] -> ShowS
</> Instrument -> [Char]
instrumentToDir Instrument
inst [Char] -> ShowS
</> ChunkNum -> [Char]
chunkName ChunkNum
chunknum

chunkName :: ChunkNum -> FilePath
chunkName :: ChunkNum -> [Char]
chunkName ChunkNum
chunknum = Text -> [Char]
untxt (forall a. Show a => ChunkNum -> a -> Text
Num.zeroPad ChunkNum
3 ChunkNum
chunknum forall a. Semigroup a => a -> a -> a
<> Text
".wav")

-- | This relies on the format from 'chunkName'.
isOutputLink :: FilePath -> Maybe ChunkNum
isOutputLink :: [Char] -> Maybe ChunkNum
isOutputLink (Char
c1:Char
c2:Char
c3 : [Char]
".wav")
    | Just ChunkNum
n <- forall a. Read a => [Char] -> Maybe a
Read.readMaybe [Char
c1, Char
c2, Char
c3] = forall a. a -> Maybe a
Just ChunkNum
n
    | Bool
otherwise = forall a. Maybe a
Nothing
isOutputLink [Char]
_ = forall a. Maybe a
Nothing

-- | This is text sent over MIDI to tell play_cache which directory to play
-- from.  Relative to imDir/cacheDir.
playFilename :: FilePath -> Id.BlockId -> FilePath
playFilename :: [Char] -> BlockId -> [Char]
playFilename [Char]
scorePath BlockId
blockId = [Char]
scorePath [Char] -> ShowS
</> forall a. Ident a => a -> [Char]
idFilename BlockId
blockId

idFilename :: Id.Ident a => a -> FilePath
idFilename :: forall a. Ident a => a -> [Char]
idFilename a
id = Text -> [Char]
untxt forall a b. (a -> b) -> a -> b
$ Namespace -> Text
Id.un_namespace Namespace
ns forall a. Semigroup a => a -> a -> a
<> Text
"/" forall a. Semigroup a => a -> a -> a
<> Text
name
    where (Namespace
ns, Text
name) = Id -> (Namespace, Text)
Id.un_id forall a b. (a -> b) -> a -> b
$ forall a. Ident a => a -> Id
Id.unpack_id a
id

-- | Delete output links for instruments that have disappeared entirely.
-- This often happens when I disable a track.
clearUnusedInstruments :: FilePath -> HashSet ScoreT.Instrument -> IO ()
clearUnusedInstruments :: [Char] -> HashSet Instrument -> IO ()
clearUnusedInstruments [Char]
outputDir HashSet Instrument
instruments = do
    [[Char]]
dirs <- forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM ([Char] -> IO Bool
Directory.doesDirectoryExist forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
outputDir</>))
        forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Char] -> IO [[Char]]
listDir [Char]
outputDir
    let unused :: [[Char]]
unused = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Bool
dirInInstruments) [[Char]]
dirs
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [[Char]]
unused forall a b. (a -> b) -> a -> b
$ \[Char]
dir -> do
        [[Char]]
links <- forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Maybe a -> Bool
Maybe.isJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Maybe ChunkNum
isOutputLink) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            [Char] -> IO [[Char]]
listDir ([Char]
outputDir [Char] -> ShowS
</> [Char]
dir)
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ([Char] -> IO ()
Directory.removeFile forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Char]
outputDir [Char] -> ShowS
</> [Char]
dir) </>)) [[Char]]
links
    where
    dirInInstruments :: [Char] -> Bool
dirInInstruments = (forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
`HashSet.member` HashSet Instrument
instruments) forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Instrument
dirToInstrument

-- | There is a subdirectory for each instrument.  There has to be a direct
-- correspondance with ScoreT.Instrument, because clearUnusedInstruments
-- uses it.
instrumentToDir :: ScoreT.Instrument -> FilePath
instrumentToDir :: Instrument -> [Char]
instrumentToDir = Text -> [Char]
untxt forall b c a. (b -> c) -> (a -> b) -> a -> c
. Instrument -> Text
ScoreT.instrument_name

dirToInstrument :: FilePath -> ScoreT.Instrument
dirToInstrument :: [Char] -> Instrument
dirToInstrument = Text -> Instrument
ScoreT.Instrument forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
txt forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
FilePath.takeFileName

listDir :: FilePath -> IO [FilePath]
listDir :: [Char] -> IO [[Char]]
listDir = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> Maybe a -> a
fromMaybe []) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IO a -> IO (Maybe a)
Exceptions.ignoreEnoent
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> IO [[Char]]
Directory.listDirectory

-- * progress

data Message = Message {
    Message -> BlockId
_blockId :: !Id.BlockId
    , Message -> Set TrackId
_trackIds :: !(Set Id.TrackId)
    , Message -> Instrument
_instrument :: !ScoreT.Instrument
    , Message -> Payload
_payload :: !Payload
    }
    deriving (ChunkNum -> Message -> ShowS
[Message] -> ShowS
Message -> [Char]
forall a.
(ChunkNum -> a -> ShowS)
-> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Message] -> ShowS
$cshowList :: [Message] -> ShowS
show :: Message -> [Char]
$cshow :: Message -> [Char]
showsPrec :: ChunkNum -> Message -> ShowS
$cshowsPrec :: ChunkNum -> Message -> ShowS
Show, forall x. Rep Message x -> Message
forall x. Message -> Rep Message x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Message x -> Message
$cfrom :: forall x. Message -> Rep Message x
Generics.Generic)

instance Aeson.ToJSON Message where
    toEncoding :: Message -> Encoding
toEncoding = forall a.
(Generic a, GToJSON' Encoding Zero (Rep a)) =>
Options -> a -> Encoding
Aeson.genericToEncoding Options
Aeson.defaultOptions
instance Aeson.FromJSON Message

data Payload =
    RenderingRange !RealTime !RealTime
    -- | Completed waveforms.
    | WaveformsCompleted ![ChunkNum]
    | Warn !Stack.Stack !Text
    -- | A failure will cause karya to log the msg and mark the track as
    -- incomplete.  It should be fatal, so don't do any 'emitMessage'
    -- afterwards.
    | Failure !Text
    deriving (ChunkNum -> Payload -> ShowS
[Payload] -> ShowS
Payload -> [Char]
forall a.
(ChunkNum -> a -> ShowS)
-> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Payload] -> ShowS
$cshowList :: [Payload] -> ShowS
show :: Payload -> [Char]
$cshow :: Payload -> [Char]
showsPrec :: ChunkNum -> Payload -> ShowS
$cshowsPrec :: ChunkNum -> Payload -> ShowS
Show, forall x. Rep Payload x -> Payload
forall x. Payload -> Rep Payload x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Payload x -> Payload
$cfrom :: forall x. Payload -> Rep Payload x
Generics.Generic)

instance Aeson.ToJSON Payload where
    toEncoding :: Payload -> Encoding
toEncoding = forall a.
(Generic a, GToJSON' Encoding Zero (Rep a)) =>
Options -> a -> Encoding
Aeson.genericToEncoding Options
Aeson.defaultOptions
instance Aeson.FromJSON Payload

emitMessage :: GHC.Stack.HasCallStack => Message -> IO ()
emitMessage :: HasCallStack => Message -> IO ()
emitMessage Message
msg = do
    let prio :: Priority
prio = case Message -> Payload
_payload Message
msg of
            RenderingRange {} -> Priority
Log.Debug
            WaveformsCompleted {} -> Priority
Log.Debug
            Warn {} -> Priority
Log.Warn
            Failure {} -> Priority
Log.Warn
    forall (m :: * -> *).
(HasCallStack, LogMonad m) =>
Priority -> Text -> m ()
Log.log Priority
prio forall a b. (a -> b) -> a -> b
$ [Text] -> Text
Text.unwords forall a b. (a -> b) -> a -> b
$
        [ forall a. Ident a => a -> Text
Id.ident_text (Message -> BlockId
_blockId Message
msg)
        , forall a. Pretty a => a -> Text
pretty (forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map forall a. Ident a => a -> Text
Id.ident_text (Message -> Set TrackId
_trackIds Message
msg))
        , case Message -> Payload
_payload Message
msg of
            RenderingRange RealTime
start RealTime
end -> forall a. Pretty a => a -> Text
pretty RealTime
start forall a. Semigroup a => a -> a -> a
<> Text
"--" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty RealTime
end
            WaveformsCompleted [ChunkNum]
chunknums -> Text
"completed: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty [ChunkNum]
chunknums
            Warn Stack
stack Text
err -> forall a. Pretty a => a -> Text
pretty Stack
stack forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> Text
err
            Failure Text
err -> Text
err
        ]
    IO () -> IO ()
Log.with_stdio_lock forall a b. (a -> b) -> a -> b
$ do
        ByteString -> IO ()
ByteString.Lazy.Char8.putStrLn forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> ByteString
Aeson.encode Message
msg
        Handle -> IO ()
IO.hFlush Handle
IO.stdout

parseMessage :: Text -> Maybe Message
parseMessage :: Text -> Maybe Message
parseMessage = forall a. FromJSON a => ByteString -> Maybe a
Aeson.decode forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Textlike a => a -> ByteString
Texts.toLazyByteString

-- | Infer namespace/block from
-- .../im/cache/$scorePath/$scoreFname/$namespace/$block/$instrument
pathToBlockId :: FilePath -> Id.BlockId
pathToBlockId :: [Char] -> BlockId
pathToBlockId = Id -> BlockId
Id.BlockId forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Id
Id.read_id
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text] -> Text
Text.intercalate Text
"/" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ChunkNum -> [a] -> [a]
take ChunkNum
2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ChunkNum -> [a] -> [a]
Lists.takeEnd ChunkNum
3 forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> [Text]
Text.splitOn Text
"/" forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
txt