-- 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.Log as Log
import qualified Util.Num as Num
import qualified Util.Seq as Seq
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 -> FilePath
imDir :: FilePath
    , Config -> Map Text Synth
synths :: Map SynthName Synth
    }
    deriving (Config -> Config -> Bool
(Config -> Config -> Bool)
-> (Config -> Config -> Bool) -> Eq Config
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 -> FilePath
(ChunkNum -> Config -> ShowS)
-> (Config -> FilePath) -> ([Config] -> ShowS) -> Show Config
forall a.
(ChunkNum -> a -> ShowS)
-> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Config] -> ShowS
$cshowList :: [Config] -> ShowS
show :: Config -> FilePath
$cshow :: Config -> FilePath
showsPrec :: ChunkNum -> Config -> ShowS
$cshowsPrec :: ChunkNum -> Config -> ShowS
Show)

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

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

config :: Path.AppDir -> Config
config :: AppDir -> Config
config AppDir
appDir = Config
    { imDir :: FilePath
imDir = AppDir -> Relative -> FilePath
Path.to_absolute AppDir
appDir Relative
Config.im_dir
    , synths :: Map Text Synth
synths = [(Text, Synth)] -> Map Text Synth
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 -> FilePath
synthName :: !FilePath
    -- | Path to the binary.  Don't run a binary if it's empty.
    , Synth -> FilePath
binary :: !FilePath
    } deriving (Synth -> Synth -> Bool
(Synth -> Synth -> Bool) -> (Synth -> Synth -> Bool) -> Eq Synth
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 -> FilePath
(ChunkNum -> Synth -> ShowS)
-> (Synth -> FilePath) -> ([Synth] -> ShowS) -> Show Synth
forall a.
(ChunkNum -> a -> ShowS)
-> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Synth] -> ShowS
$cshowList :: [Synth] -> ShowS
show :: Synth -> FilePath
$cshow :: Synth -> FilePath
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 :: FilePath
synthName = FilePath
"sampler"
    , binary :: FilePath
binary = FilePath
"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 :: FilePath
unsafeSamplerRoot =
    AppDir -> Relative -> FilePath
Path.to_absolute (IO AppDir -> AppDir
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 :: FilePath
synthName = FilePath
"faust"
    , binary :: FilePath
binary = FilePath
"build/opt/faust-im"
    }

ness ::Synth
ness :: Synth
ness = Synth
    { synthName :: FilePath
synthName = FilePath
"ness"
    , binary :: FilePath
binary = FilePath
""
    }

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

-- | All rendered output is in im </> cacheDir.
cacheDir :: FilePath
cacheDir :: FilePath
cacheDir = FilePath
"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 (ChunkNum -> Frames) -> ChunkNum -> Frames
forall a b. (a -> b) -> a -> b
$ ChunkNum
samplingRate ChunkNum -> ChunkNum -> ChunkNum
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 Frames -> Frames -> Frames
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 :: FilePath -> FilePath -> BlockId -> Synth -> FilePath
notesFilename FilePath
imDir FilePath
scorePath BlockId
blockId Synth
synth =
    FilePath -> FilePath -> BlockId -> FilePath
notesDirectory FilePath
imDir FilePath
scorePath BlockId
blockId FilePath -> ShowS
</> Synth -> FilePath
synthName Synth
synth

notesDirectory :: FilePath -> FilePath -> Id.BlockId -> FilePath
notesDirectory :: FilePath -> FilePath -> BlockId -> FilePath
notesDirectory FilePath
imDir FilePath
scorePath BlockId
blockId =
    FilePath
imDir FilePath -> ShowS
</> FilePath
notesParentDir FilePath -> ShowS
</> FilePath
scorePath FilePath -> ShowS
</> BlockId -> FilePath
forall a. Ident a => a -> FilePath
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 :: FilePath -> FilePath -> BlockId -> FilePath
outputDirectory FilePath
imDir FilePath
scorePath BlockId
blockId =
    FilePath
imDir FilePath -> ShowS
</> FilePath
cacheDir FilePath -> ShowS
</> FilePath
scorePath FilePath -> ShowS
</> BlockId -> FilePath
forall a. Ident a => a -> FilePath
idFilename BlockId
blockId

-- | Get the filename for a particular checkpoint.
chunkPath :: FilePath -> FilePath -> Id.BlockId -> InstrumentDir -> ChunkNum
    -> FilePath
chunkPath :: FilePath
-> FilePath -> BlockId -> InstrumentDir -> ChunkNum -> FilePath
chunkPath FilePath
imDir FilePath
scorePath BlockId
blockId (InstrumentDir FilePath
instrument) ChunkNum
chunknum =
    FilePath -> FilePath -> BlockId -> FilePath
outputDirectory FilePath
imDir FilePath
scorePath BlockId
blockId
        FilePath -> ShowS
</> FilePath
instrument FilePath -> ShowS
</> ChunkNum -> FilePath
chunkName ChunkNum
chunknum

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

-- | This relies on the format from 'chunkName'.
isOutputLink :: FilePath -> Maybe ChunkNum
isOutputLink :: FilePath -> Maybe ChunkNum
isOutputLink (Char
c1:Char
c2:Char
c3 : FilePath
".wav")
    | Just ChunkNum
n <- FilePath -> Maybe ChunkNum
forall a. Read a => FilePath -> Maybe a
Read.readMaybe [Char
c1, Char
c2, Char
c3] = ChunkNum -> Maybe ChunkNum
forall a. a -> Maybe a
Just ChunkNum
n
    | Bool
otherwise = Maybe ChunkNum
forall a. Maybe a
Nothing
isOutputLink FilePath
_ = Maybe ChunkNum
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 :: FilePath -> BlockId -> FilePath
playFilename FilePath
scorePath BlockId
blockId = FilePath
scorePath FilePath -> ShowS
</> BlockId -> FilePath
forall a. Ident a => a -> FilePath
idFilename BlockId
blockId

idFilename :: Id.Ident a => a -> FilePath
idFilename :: forall a. Ident a => a -> FilePath
idFilename a
id = Text -> FilePath
untxt (Text -> FilePath) -> Text -> FilePath
forall a b. (a -> b) -> a -> b
$ Namespace -> Text
Id.un_namespace Namespace
ns Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name
    where (Namespace
ns, Text
name) = Id -> (Namespace, Text)
Id.un_id (Id -> (Namespace, Text)) -> Id -> (Namespace, Text)
forall a b. (a -> b) -> a -> b
$ a -> Id
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 :: FilePath -> HashSet Instrument -> IO ()
clearUnusedInstruments FilePath
outputDir HashSet Instrument
instruments = do
    [FilePath]
dirs <- (FilePath -> IO Bool) -> [FilePath] -> IO [FilePath]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (FilePath -> IO Bool
Directory.doesDirectoryExist (FilePath -> IO Bool) -> ShowS -> FilePath -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath
outputDir</>))
        ([FilePath] -> IO [FilePath]) -> IO [FilePath] -> IO [FilePath]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FilePath -> IO [FilePath]
listDir FilePath
outputDir
    let unused :: [FilePath]
unused = (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter
            (Bool -> Bool
not (Bool -> Bool) -> (FilePath -> Bool) -> FilePath -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Instrument -> HashSet Instrument -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
`HashSet.member` HashSet Instrument
instruments) (Instrument -> Bool)
-> (FilePath -> Instrument) -> FilePath -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InstrumentDir -> Instrument
dirInstrument
                (InstrumentDir -> Instrument)
-> (FilePath -> InstrumentDir) -> FilePath -> Instrument
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> InstrumentDir
instrumentDir)
            [FilePath]
dirs
    [FilePath] -> (FilePath -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [FilePath]
unused ((FilePath -> IO ()) -> IO ()) -> (FilePath -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \FilePath
dir -> do
        [FilePath]
links <- (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter (Maybe ChunkNum -> Bool
forall a. Maybe a -> Bool
Maybe.isJust (Maybe ChunkNum -> Bool)
-> (FilePath -> Maybe ChunkNum) -> FilePath -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Maybe ChunkNum
isOutputLink) ([FilePath] -> [FilePath]) -> IO [FilePath] -> IO [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            FilePath -> IO [FilePath]
listDir (FilePath
outputDir FilePath -> ShowS
</> FilePath
dir)
        (FilePath -> IO ()) -> [FilePath] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (FilePath -> IO ()
Directory.removeFile (FilePath -> IO ()) -> ShowS -> FilePath -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((FilePath
outputDir FilePath -> ShowS
</> FilePath
dir) </>)) [FilePath]
links

-- | There is a subdirectory for each instrument, but it has extra info, so it
-- can't directly be a ScoreT.Instrument.  Instruments never have '_', so I can
-- use that to put extra info on the end.  For faust, I put the patch name, so
-- I can clear obsolete checkpoints when the patch changes.
newtype InstrumentDir = InstrumentDir FilePath
    deriving (InstrumentDir -> InstrumentDir -> Bool
(InstrumentDir -> InstrumentDir -> Bool)
-> (InstrumentDir -> InstrumentDir -> Bool) -> Eq InstrumentDir
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: InstrumentDir -> InstrumentDir -> Bool
$c/= :: InstrumentDir -> InstrumentDir -> Bool
== :: InstrumentDir -> InstrumentDir -> Bool
$c== :: InstrumentDir -> InstrumentDir -> Bool
Eq, ChunkNum -> InstrumentDir -> ShowS
[InstrumentDir] -> ShowS
InstrumentDir -> FilePath
(ChunkNum -> InstrumentDir -> ShowS)
-> (InstrumentDir -> FilePath)
-> ([InstrumentDir] -> ShowS)
-> Show InstrumentDir
forall a.
(ChunkNum -> a -> ShowS)
-> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [InstrumentDir] -> ShowS
$cshowList :: [InstrumentDir] -> ShowS
show :: InstrumentDir -> FilePath
$cshow :: InstrumentDir -> FilePath
showsPrec :: ChunkNum -> InstrumentDir -> ShowS
$cshowsPrec :: ChunkNum -> InstrumentDir -> ShowS
Show, [InstrumentDir] -> Doc
InstrumentDir -> Text
InstrumentDir -> Doc
(InstrumentDir -> Text)
-> (InstrumentDir -> Doc)
-> ([InstrumentDir] -> Doc)
-> Pretty InstrumentDir
forall a. (a -> Text) -> (a -> Doc) -> ([a] -> Doc) -> Pretty a
formatList :: [InstrumentDir] -> Doc
$cformatList :: [InstrumentDir] -> Doc
format :: InstrumentDir -> Doc
$cformat :: InstrumentDir -> Doc
pretty :: InstrumentDir -> Text
$cpretty :: InstrumentDir -> Text
Pretty, [InstrumentDir] -> Encoding
[InstrumentDir] -> Value
InstrumentDir -> Encoding
InstrumentDir -> Value
(InstrumentDir -> Value)
-> (InstrumentDir -> Encoding)
-> ([InstrumentDir] -> Value)
-> ([InstrumentDir] -> Encoding)
-> ToJSON InstrumentDir
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [InstrumentDir] -> Encoding
$ctoEncodingList :: [InstrumentDir] -> Encoding
toJSONList :: [InstrumentDir] -> Value
$ctoJSONList :: [InstrumentDir] -> Value
toEncoding :: InstrumentDir -> Encoding
$ctoEncoding :: InstrumentDir -> Encoding
toJSON :: InstrumentDir -> Value
$ctoJSON :: InstrumentDir -> Value
Aeson.ToJSON, Value -> Parser [InstrumentDir]
Value -> Parser InstrumentDir
(Value -> Parser InstrumentDir)
-> (Value -> Parser [InstrumentDir]) -> FromJSON InstrumentDir
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [InstrumentDir]
$cparseJSONList :: Value -> Parser [InstrumentDir]
parseJSON :: Value -> Parser InstrumentDir
$cparseJSON :: Value -> Parser InstrumentDir
Aeson.FromJSON)

instrumentDir :: FilePath -> InstrumentDir
instrumentDir :: FilePath -> InstrumentDir
instrumentDir = FilePath -> InstrumentDir
InstrumentDir (FilePath -> InstrumentDir) -> ShowS -> FilePath -> InstrumentDir
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
FilePath.takeFileName

instrumentDir2 :: ScoreT.Instrument -> Maybe String -> FilePath
instrumentDir2 :: Instrument -> Maybe FilePath -> FilePath
instrumentDir2 Instrument
inst Maybe FilePath
extra =
    Text -> FilePath
untxt (Instrument -> Text
ScoreT.instrument_name Instrument
inst) FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath -> ShowS -> Maybe FilePath -> FilePath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe FilePath
"" (FilePath
"_"<>) Maybe FilePath
extra

dirInstrument :: InstrumentDir -> ScoreT.Instrument
dirInstrument :: InstrumentDir -> Instrument
dirInstrument (InstrumentDir FilePath
dir) =
    Text -> Instrument
ScoreT.Instrument (Text -> Instrument) -> Text -> Instrument
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
txt (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'_') FilePath
dir

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

-- * progress

data Message = Message {
    Message -> BlockId
_blockId :: !Id.BlockId
    , Message -> Set TrackId
_trackIds :: !(Set Id.TrackId)
    , Message -> InstrumentDir
_instrument :: !InstrumentDir
    , Message -> Payload
_payload :: !Payload
    }
    deriving (ChunkNum -> Message -> ShowS
[Message] -> ShowS
Message -> FilePath
(ChunkNum -> Message -> ShowS)
-> (Message -> FilePath) -> ([Message] -> ShowS) -> Show Message
forall a.
(ChunkNum -> a -> ShowS)
-> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Message] -> ShowS
$cshowList :: [Message] -> ShowS
show :: Message -> FilePath
$cshow :: Message -> FilePath
showsPrec :: ChunkNum -> Message -> ShowS
$cshowsPrec :: ChunkNum -> Message -> ShowS
Show, (forall x. Message -> Rep Message x)
-> (forall x. Rep Message x -> Message) -> Generic Message
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 = Options -> Message -> Encoding
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 -> FilePath
(ChunkNum -> Payload -> ShowS)
-> (Payload -> FilePath) -> ([Payload] -> ShowS) -> Show Payload
forall a.
(ChunkNum -> a -> ShowS)
-> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Payload] -> ShowS
$cshowList :: [Payload] -> ShowS
show :: Payload -> FilePath
$cshow :: Payload -> FilePath
showsPrec :: ChunkNum -> Payload -> ShowS
$cshowsPrec :: ChunkNum -> Payload -> ShowS
Show, (forall x. Payload -> Rep Payload x)
-> (forall x. Rep Payload x -> Payload) -> Generic Payload
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 = Options -> Payload -> Encoding
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
    Priority -> Text -> IO ()
forall (m :: * -> *).
(HasCallStack, LogMonad m) =>
Priority -> Text -> m ()
Log.log Priority
prio (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
Text.unwords ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
        [ BlockId -> Text
forall a. Ident a => a -> Text
Id.ident_text (Message -> BlockId
_blockId Message
msg)
        , Set Text -> Text
forall a. Pretty a => a -> Text
pretty ((TrackId -> Text) -> Set TrackId -> Set Text
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map TrackId -> Text
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 -> RealTime -> Text
forall a. Pretty a => a -> Text
pretty RealTime
start Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"--" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> RealTime -> Text
forall a. Pretty a => a -> Text
pretty RealTime
end
            WaveformsCompleted [ChunkNum]
chunknums -> Text
"completed: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [ChunkNum] -> Text
forall a. Pretty a => a -> Text
pretty [ChunkNum]
chunknums
            Warn Stack
stack Text
err -> Stack -> Text
forall a. Pretty a => a -> Text
pretty Stack
stack Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
err
            Failure Text
err -> Text
err
        ]
    IO () -> IO ()
Log.with_stdio_lock (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        ByteString -> IO ()
ByteString.Lazy.Char8.putStrLn (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ Message -> ByteString
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 = ByteString -> Maybe Message
forall a. FromJSON a => ByteString -> Maybe a
Aeson.decode (ByteString -> Maybe Message)
-> (Text -> ByteString) -> Text -> Maybe Message
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
forall a. Textlike a => a -> ByteString
Texts.toLazyByteString

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