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

-- | Utilities to directly perform a saved score.
module Derive.DeriveSaved where
import qualified Control.Exception as Exception
import qualified Control.Monad.Except as Except
import qualified Data.Text.IO as Text.IO
import qualified Data.Text.Lazy as Lazy
import qualified Data.Vector as Vector

import qualified System.FilePath as FilePath
import qualified System.IO as IO
import qualified Text.Printf as Printf

import qualified Util.Log as Log
import qualified Util.Test.Testing as Testing
import qualified Util.Thread as Thread

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

import qualified Cmd.Cmd as Cmd
import qualified Cmd.Ky as Ky
import qualified Cmd.Lilypond
import qualified Cmd.Msg as Msg
import qualified Cmd.Performance as Performance
import qualified Cmd.PlayUtil as PlayUtil
import qualified Cmd.Save as Save
import qualified Cmd.SaveGit as SaveGit
import qualified Cmd.SaveGitT as SaveGitT

import qualified Derive.C.All as C.All
import qualified Derive.Cache as Cache
import qualified Derive.Derive as Derive
import qualified Derive.LEvent as LEvent
import qualified Derive.Score as Score
import qualified Derive.Stream as Stream

import qualified Local.Config
import qualified Midi.Midi as Midi
import qualified Midi.StubMidi as StubMidi
import qualified Perform.Sc.Note as Sc.Note
import qualified Synth.Shared.Config as Shared.Config
import qualified Ui.Ui as Ui
import qualified Ui.UiConfig as UiConfig

import           Global
import           Types


perform_file :: Cmd.Config -> FilePath -> IO [Midi.WriteMessage]
perform_file :: Config -> [Char] -> IO [WriteMessage]
perform_file Config
cmd_config [Char]
fname = do
    (State
ui_state, State
cmd_state) <- Config -> [Char] -> IO (State, State)
load_score_states Config
cmd_config [Char]
fname
    BlockId
root_id <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. (Stack, MonadIO m) => Text -> m a
errorIO forall a b. (a -> b) -> a -> b
$ [Char] -> Text
txt [Char]
fname forall a. Semigroup a => a -> a -> a
<> Text
": no root block") forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
        Lens State Config
Ui.configforall a b c. Lens a b -> Lens b c -> Lens a c
#Config :-> Maybe BlockId
UiConfig.root forall f a. Lens f a -> f -> a
#$ State
ui_state
    ((Vector Event
events, [Msg]
logs), Seconds
_cpu) <- [Char]
-> State -> State -> BlockId -> IO ((Vector Event, [Msg]), Seconds)
timed_derive [Char]
fname State
ui_state State
cmd_state BlockId
root_id
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *). LogMonad m => Msg -> m ()
Log.write [Msg]
logs
    (([WriteMessage]
msgs, [Msg]
logs), Seconds
_cpu) <- State
-> [Char]
-> State
-> Vector Event
-> IO (([WriteMessage], [Msg]), Seconds)
timed_perform State
cmd_state ([Char]
"perform " forall a. [a] -> [a] -> [a]
++ [Char]
fname)
        State
ui_state Vector Event
events
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *). LogMonad m => Msg -> m ()
Log.write [Msg]
logs
    forall (m :: * -> *) a. Monad m => a -> m a
return [WriteMessage]
msgs

timed_perform :: Cmd.State -> FilePath -> Ui.State
    -> Vector.Vector Score.Event -> IO (([Midi.WriteMessage], [Log.Msg]), CPU)
timed_perform :: State
-> [Char]
-> State
-> Vector Event
-> IO (([WriteMessage], [Msg]), Seconds)
timed_perform State
cmd_state [Char]
fname State
state Vector Event
events =
    forall a.
Text -> (Metric Seconds -> a -> [Char]) -> IO a -> IO (a, Seconds)
time (Text
"perform " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
txt [Char]
fname) (forall a. (a -> Int) -> Metric Seconds -> a -> [Char]
timer_msg (forall (t :: * -> *) a. Foldable t => t a -> Int
length forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst)) forall a b. (a -> b) -> a -> b
$ do
        let ([WriteMessage]
msgs, [Msg]
logs) = forall d. [LEvent d] -> ([d], [Msg])
LEvent.partition forall a b. (a -> b) -> a -> b
$
                State -> State -> Vector Event -> [LEvent WriteMessage]
perform_midi State
cmd_state State
state Vector Event
events
        forall a. NFData a => a -> IO ()
Testing.force ([WriteMessage]
msgs, [Msg]
logs)
        forall (m :: * -> *) a. Monad m => a -> m a
return ([WriteMessage]
msgs, [Msg]
logs)

timed_derive :: FilePath -> Ui.State -> Cmd.State -> BlockId
    -> IO ((Vector.Vector Score.Event, [Log.Msg]), CPU)
timed_derive :: [Char]
-> State -> State -> BlockId -> IO ((Vector Event, [Msg]), Seconds)
timed_derive [Char]
fname State
ui_state State
cmd_state BlockId
block_id = do
    let (Performance
perf, [Msg]
logs) = State -> State -> BlockId -> (Performance, [Msg])
Performance.derive State
ui_state State
cmd_state BlockId
block_id
    (Vector Event
_, Seconds
cpu) <- forall a.
Text -> (Metric Seconds -> a -> [Char]) -> IO a -> IO (a, Seconds)
time (Text
"derive " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
txt [Char]
fname) (forall a. (a -> Int) -> Metric Seconds -> a -> [Char]
timer_msg forall a. Vector a -> Int
Vector.length) forall a b. (a -> b) -> a -> b
$ do
        () <- forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Performance -> ()
Msg.force_performance Performance
perf
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! Performance -> Vector Event
Cmd.perf_events Performance
perf
    let warns :: [Msg]
warns = forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Ord a => a -> a -> Bool
>=Priority
Log.Warn) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Msg -> Priority
Log.msg_priority) (Performance -> [Msg]
Cmd.perf_logs Performance
perf)
    forall (m :: * -> *) a. Monad m => a -> m a
return ((Performance -> Vector Event
Cmd.perf_events Performance
perf, [Msg]
warns forall a. [a] -> [a] -> [a]
++ [Msg]
logs), Seconds
cpu)

-- | This is like 'timed_derive', except that it does more work itself
-- rather than calling Performance.derive.  This can be more convenient to
-- look at derivation results.
timed_derive2 :: FilePath -> Ui.State -> Cmd.State -> BlockId
    -> IO ((Vector.Vector Score.Event, [Log.Msg]), CPU)
timed_derive2 :: [Char]
-> State -> State -> BlockId -> IO ((Vector Event, [Msg]), Seconds)
timed_derive2 [Char]
fname State
ui_state State
cmd_state BlockId
block_id =
    case State -> State -> BlockId -> Either Text (Result, [Msg])
derive_block State
ui_state State
cmd_state BlockId
block_id of
        Left Text
err -> forall (m :: * -> *) a. Monad m => a -> m a
return ((forall a. Monoid a => a
mempty, [Stack => Priority -> Maybe Stack -> Text -> Msg
Log.msg Priority
Log.Warn forall a. Maybe a
Nothing Text
err]), Seconds
0)
        Right (Result
result, [Msg]
cmd_logs) -> do
            let (Vector Event
events, [Msg]
derive_logs) = forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall a. [a] -> Vector a
Vector.fromList forall a b. (a -> b) -> a -> b
$
                    forall a. Stream a -> ([a], [Msg])
Stream.partition forall a b. (a -> b) -> a -> b
$ Result -> Stream Event
Derive.r_events Result
result
                msg :: Text
msg = Text
"derive " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
txt [Char]
fname forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty BlockId
block_id
            (Vector Event
events, Seconds
cpu) <- forall a.
Text -> (Metric Seconds -> a -> [Char]) -> IO a -> IO (a, Seconds)
time Text
msg (forall a. (a -> Int) -> Metric Seconds -> a -> [Char]
timer_msg forall a. Vector a -> Int
Vector.length)
                (forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! Vector Event
events)
            forall (m :: * -> *) a. Monad m => a -> m a
return
                ( (Vector Event
events, [Msg]
cmd_logs forall a. [a] -> [a] -> [a]
++ forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Msg -> Bool
boring) [Msg]
derive_logs)
                , Seconds
cpu
                )
    where
    boring :: Msg -> Bool
boring = Msg -> Bool
Cache.is_cache_log
    derive_block :: Ui.State -> Cmd.State -> BlockId
        -> Either Text (Derive.Result, [Log.Msg])
    derive_block :: State -> State -> BlockId -> Either Text (Result, [Msg])
derive_block State
ui_state State
cmd_state BlockId
block_id =
        forall a. State -> State -> CmdId a -> Either Text (a, [Msg])
run_cmd State
ui_state State
cmd_state forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). M m => BlockId -> m Result
PlayUtil.uncached_derive BlockId
block_id

timed_lilypond :: FilePath -> Ui.State -> Cmd.State -> BlockId
    -> IO ((Either Log.Msg Text, [Log.Msg]), CPU)
timed_lilypond :: [Char]
-> State
-> State
-> BlockId
-> IO ((Either Msg Text, [Msg]), Seconds)
timed_lilypond [Char]
fname State
ui_state State
cmd_state BlockId
block_id = case Either Text (Stream Event, [Msg])
result of
    Left Text
err -> forall (m :: * -> *) a. Monad m => a -> m a
return ((forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Stack => Priority -> Maybe Stack -> Text -> Msg
Log.msg Priority
Log.Warn forall a. Maybe a
Nothing Text
err, []), Seconds
0)
    Right (Stream Event
levents, [Msg]
cmd_logs) -> do
        let ([Event]
events, [Msg]
derive_logs) = forall a. Stream a -> ([a], [Msg])
Stream.partition Stream Event
levents
        ([Event]
events, Seconds
cpu) <- forall a.
Text -> (Metric Seconds -> a -> [Char]) -> IO a -> IO (a, Seconds)
time (Text
"lilypond " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
txt [Char]
fname)
            (forall a. (a -> Int) -> Metric Seconds -> a -> [Char]
timer_msg forall (t :: * -> *) a. Foldable t => t a -> Int
length) (forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! [Event]
events)
        let (Either Msg Text
result, [Msg]
ly_logs) = Config -> Text -> [Event] -> (Either Msg Text, [Msg])
Cmd.Lilypond.extract_movements
                Config
config Text
"title" [Event]
events
        let logs :: [Msg]
logs = [Msg]
cmd_logs forall a. [a] -> [a] -> [a]
++ forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Msg -> Bool
boring) [Msg]
derive_logs forall a. [a] -> [a] -> [a]
++ [Msg]
ly_logs
        forall (m :: * -> *) a. Monad m => a -> m a
return ((Text -> Text
Lazy.toStrict forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Msg Text
result, [Msg]
logs), Seconds
cpu)
    where
    result :: Either Text (Stream Event, [Msg])
result = forall a. State -> State -> CmdId a -> Either Text (a, [Msg])
run_cmd State
ui_state State
cmd_state forall a b. (a -> b) -> a -> b
$
        Result -> Stream Event
Derive.r_events forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => BlockId -> m Result
Cmd.Lilypond.derive_block BlockId
block_id
    config :: Config
config = Lens State Config
Ui.configforall a b c. Lens a b -> Lens b c -> Lens a c
#Config :-> Config
UiConfig.lilypond forall f a. Lens f a -> f -> a
#$ State
ui_state
    boring :: Msg -> Bool
boring = Msg -> Bool
Cache.is_cache_log

timer_msg :: (a -> Int) -> Thread.Metric Thread.Seconds -> a -> String
timer_msg :: forall a. (a -> Int) -> Metric Seconds -> a -> [Char]
timer_msg a -> Int
len (Thread.Metric Seconds
cpu_secs Seconds
wall_secs) a
events =
    forall r. PrintfType r => [Char] -> r
Printf.printf [Char]
"events: %d (%d / cpu, %d / sec)"
        Int
events_len (Seconds -> Int
per Seconds
cpu_secs) (Seconds -> Int
per Seconds
wall_secs)
    where
    events_len :: Int
events_len = a -> Int
len a
events
    per :: Thread.Seconds -> Int
    per :: Seconds -> Int
per Seconds
secs = forall a b. (RealFrac a, Integral b) => a -> b
round (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
events_len forall a. Fractional a => a -> a -> a
/ Seconds -> Double
toSecs Seconds
secs)

run_cmd :: Ui.State -> Cmd.State -> Cmd.CmdId a -> Either Text (a, [Log.Msg])
run_cmd :: forall a. State -> State -> CmdId a -> Either Text (a, [Msg])
run_cmd State
ui_state State
cmd_state CmdId a
cmd = case Either Error (Maybe a, State, UiDamage)
result of
    Left Error
err -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> Text
pretty Error
err
    Right (Maybe a
val, State
_, UiDamage
_) -> case Maybe a
val of
        Maybe a
Nothing -> forall a b. a -> Either a b
Left Text
"cmd had no result"
        Just a
val -> forall a b. b -> Either a b
Right (a
val, [Msg]
logs)
    where (State
_, [Thru]
_, [Msg]
logs, Either Error (Maybe a, State, UiDamage)
result) = forall a. State -> State -> CmdT Identity a -> Result (Maybe a)
Cmd.run_id State
ui_state State
cmd_state CmdId a
cmd

perform :: Cmd.State -> Ui.State -> Vector.Vector Score.Event
    -> ( ([LEvent.LEvent Midi.WriteMessage], [LEvent.LEvent Sc.Note.Note])
       , [Log.Msg]
       )
perform :: State
-> State
-> Vector Event
-> (([LEvent WriteMessage], [LEvent Note]), [Msg])
perform State
cmd_state State
ui_state =
    forall {a} {a}.
Either Text (([a], [a]), [Msg]) -> (([a], [a]), [Msg])
extract forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. State -> State -> CmdId a -> Either Text (a, [Msg])
run_cmd State
ui_state State
cmd_state forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
M m =>
RealTime
-> Vector Event -> m ([LEvent WriteMessage], [LEvent Note])
PlayUtil.perform_from RealTime
0
    where
    extract :: Either Text (([a], [a]), [Msg]) -> (([a], [a]), [Msg])
extract = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\Text
err -> (([], []), [Stack => Priority -> Maybe Stack -> Text -> Msg
Log.msg Priority
Log.Error forall a. Maybe a
Nothing Text
err])) forall a. a -> a
id

perform_midi :: Cmd.State -> Ui.State -> Vector.Vector Score.Event
    -> [LEvent.LEvent Midi.WriteMessage]
perform_midi :: State -> State -> Vector Event -> [LEvent WriteMessage]
perform_midi State
cmd_state State
ui_state Vector Event
events =
    forall {a}. Either Text ([LEvent a], [Msg]) -> [LEvent a]
extract forall a b. (a -> b) -> a -> b
$ forall a. State -> State -> CmdId a -> Either Text (a, [Msg])
run_cmd State
ui_state State
cmd_state forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). M m => [Event] -> m [LEvent WriteMessage]
PlayUtil.perform_raw forall a b. (a -> b) -> a -> b
$
        forall a. Vector a -> [a]
Vector.toList Vector Event
events
    where
    extract :: Either Text ([LEvent a], [Msg]) -> [LEvent a]
extract (Left Text
err) = [forall a. Msg -> LEvent a
LEvent.Log forall a b. (a -> b) -> a -> b
$ Stack => Priority -> Maybe Stack -> Text -> Msg
Log.msg Priority
Log.Error forall a. Maybe a
Nothing Text
err]
    extract (Right ([LEvent a]
levents, [Msg]
logs)) = forall a b. (a -> b) -> [a] -> [b]
map forall a. Msg -> LEvent a
LEvent.Log [Msg]
logs forall a. [a] -> [a] -> [a]
++ [LEvent a]
levents

load_score_states :: Cmd.Config -> FilePath -> IO (Ui.State, Cmd.State)
load_score_states :: Config -> [Char] -> IO (State, State)
load_score_states Config
cmd_config [Char]
fname = do
    (State
ui_state, Builtins
library, InstrumentAliases
aliases) <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) a. (Stack, MonadIO m) => Text -> m a
errorIO forall (m :: * -> *) a. Monad m => a -> m a
return forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Char] -> IO (Either Text (State, Builtins, InstrumentAliases))
load_score [Char]
fname
    forall (m :: * -> *) a. Monad m => a -> m a
return
        ( State
ui_state
        , Builtins -> InstrumentAliases -> State -> State
add_library Builtins
library InstrumentAliases
aliases (Config -> State
Cmd.initial_state Config
cmd_config)
        )

add_library :: Derive.Builtins -> Derive.InstrumentAliases
    -> Cmd.State -> Cmd.State
add_library :: Builtins -> InstrumentAliases -> State -> State
add_library Builtins
builtins InstrumentAliases
aliases State
state =
    State
state { state_ky_cache :: Maybe KyCache
Cmd.state_ky_cache = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ (Builtins, InstrumentAliases) -> KyCache
Cmd.PermanentKy (Builtins
builtins, InstrumentAliases
aliases) }

-- | Load a score and its accompanying local definitions library, if it has one.
load_score :: FilePath
    -> IO (Either Text (Ui.State, Derive.Builtins, Derive.InstrumentAliases))
load_score :: [Char] -> IO (Either Text (State, Builtins, InstrumentAliases))
load_score [Char]
fname = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a.
Text -> (Metric Seconds -> a -> [Char]) -> IO a -> IO (a, Seconds)
time (Text
"load " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
txt [Char]
fname) (\Metric Seconds
_ Either Text (State, Builtins, InstrumentAliases)
_ -> [Char]
"") forall a b. (a -> b) -> a -> b
$
    forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
Except.runExceptT forall a b. (a -> b) -> a -> b
$ do
        SaveFile
save <- forall a. IO (Either Text a) -> ExceptT Text IO a
require_right forall a b. (a -> b) -> a -> b
$ [Char] -> IO (Either Text SaveFile)
Save.infer_save_type [Char]
fname
        (State
state, [Char]
dir) <- case SaveFile
save of
            Cmd.SaveRepo Canonical
repo -> do
                (State
state, Commit
_, [Text]
_) <- forall a. IO (Either Text a) -> ExceptT Text IO a
require_right forall a b. (a -> b) -> a -> b
$
                    [Char] -> Maybe Commit -> IO (Either Text (State, Commit, [Text]))
SaveGit.load (Canonical -> [Char]
Path.to_path Canonical
repo) forall a. Maybe a
Nothing
                forall (m :: * -> *) a. Monad m => a -> m a
return (State
state, [Char] -> [Char]
FilePath.takeDirectory (Canonical -> [Char]
Path.to_path Canonical
repo))
            Cmd.SaveState Canonical
fname -> do
                State
state <- forall a. IO (Either Text a) -> ExceptT Text IO a
require_right forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall a. Pretty a => a -> Text
pretty forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                    [Char] -> IO (Either UnserializeError State)
Save.read_state_ (Canonical -> [Char]
Path.to_path Canonical
fname)
                forall (m :: * -> *) a. Monad m => a -> m a
return (State
state, [Char] -> [Char]
FilePath.takeDirectory (Canonical -> [Char]
Path.to_path Canonical
fname))
        AppDir
app_dir <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO AppDir
Path.get_app_dir
        let paths :: [[Char]]
paths = [Char]
dir forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (AppDir -> Relative -> [Char]
Path.to_absolute AppDir
app_dir) [Relative]
Config.ky_paths
        (Builtins
builtins, InstrumentAliases
aliases) <- forall a. IO (Either Text a) -> ExceptT Text IO a
require_right forall a b. (a -> b) -> a -> b
$
            [[Char]] -> Text -> IO (Either Text (Builtins, InstrumentAliases))
Ky.load [[Char]]
paths (Lens State Config
Ui.configforall a b c. Lens a b -> Lens b c -> Lens a c
#Config :-> Text
UiConfig.ky forall f a. Lens f a -> f -> a
#$ State
state)
        forall (m :: * -> *) a. Monad m => a -> m a
return (State
state, Builtins
builtins, InstrumentAliases
aliases)

require_right :: IO (Either Text a) -> Except.ExceptT Text IO a
require_right :: forall a. IO (Either Text a) -> ExceptT Text IO a
require_right IO (Either Text a)
io = forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
tryRight forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Either Text a)
io

-- | Load cmd config, which basically means the inst db.
load_cmd_config :: IO Cmd.Config
load_cmd_config :: IO Config
load_cmd_config = do
    StaticConfig
config <- IO StaticConfig
Local.Config.load_static_config
    InstrumentDb -> IO Config
cmd_config (StaticConfig -> InstrumentDb
StaticConfig.instrument_db StaticConfig
config)

cmd_config :: Cmd.InstrumentDb -> IO Cmd.Config
cmd_config :: InstrumentDb -> IO Config
cmd_config InstrumentDb
inst_db = do
    RawInterface Message
interface <- forall a. IO (RawInterface a)
StubMidi.interface
    AppDir
app_dir <- IO AppDir
Path.get_app_dir
    Canonical
save_dir <- [Char] -> IO Canonical
Path.canonical forall a b. (a -> b) -> a -> b
$ AppDir -> Relative -> [Char]
Path.to_absolute AppDir
app_dir Relative
Config.save_dir
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Cmd.Config
        { config_app_dir :: AppDir
config_app_dir = AppDir
app_dir
        , config_save_dir :: Canonical
config_save_dir = Canonical
save_dir
        , config_midi_interface :: RawInterface Message
config_midi_interface = RawInterface Message
interface
        , config_ky_paths :: [[Char]]
config_ky_paths = forall a b. (a -> b) -> [a] -> [b]
map (AppDir -> Relative -> [Char]
Path.to_absolute AppDir
app_dir) [Relative]
Config.ky_paths
        , config_rdev_map :: Map ReadDevice ReadDevice
config_rdev_map = forall a. Monoid a => a
mempty
        , config_wdev_map :: Map WriteDevice WriteDevice
config_wdev_map = forall a. Monoid a => a
mempty
        , config_instrument_db :: InstrumentDb
config_instrument_db = InstrumentDb
inst_db
        , config_builtins :: Builtins
config_builtins = Builtins
C.All.builtins
        , config_highlight_colors :: Map Highlight Color
config_highlight_colors = forall a. Monoid a => a
mempty
        , config_im :: Config
config_im = AppDir -> Config
Shared.Config.config AppDir
app_dir
        -- You shouldn't be saving any checkpoints from here, so I can use
        -- dummy values.
        , config_git_user :: User
config_git_user = Text -> Text -> User
SaveGitT.User Text
"name" Text
"email"
        , config_im_play_direct :: Bool
config_im_play_direct = Bool
False
        }

-- * timer

-- | CPU seconds.
type CPU = Thread.Seconds

-- TODO this is mostly duplicated with Thread.printTimer, except I use
-- the timing info in the msg.
time :: Text -> (Thread.Metric Thread.Seconds -> a -> String) -> IO a
    -> IO (a, CPU)
time :: forall a.
Text -> (Metric Seconds -> a -> [Char]) -> IO a -> IO (a, Seconds)
time Text
msg Metric Seconds -> a -> [Char]
show_val IO a
op = do
    Text -> IO ()
Text.IO.putStr forall a b. (a -> b) -> a -> b
$ Text
msg forall a. Semigroup a => a -> a -> a
<> Text
" - "
    Handle -> IO ()
IO.hFlush Handle
IO.stdout
    Either SomeException (a, Metric Seconds)
result <- forall e a. Exception e => IO a -> IO (Either e a)
Exception.try forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => m a -> m (a, Metric Seconds)
Thread.timeAction forall a b. (a -> b) -> a -> b
$ do
        !a
val <- IO a
op
        forall (m :: * -> *) a. Monad m => a -> m a
return a
val
    case Either SomeException (a, Metric Seconds)
result of
        Right (a
val, Metric Seconds
metric) -> do
            [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ Metric Seconds -> a -> [Char]
show_val Metric Seconds
metric a
val
            forall (m :: * -> *) a. Monad m => a -> m a
return (a
val, forall time. Metric time -> Seconds
Thread.metricCpu Metric Seconds
metric)
        Left (SomeException
exc :: Exception.SomeException) -> do
            -- Complete the line so the exception doesn't interrupt it.  This
            -- is important if it's a 'failure' line!
            [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ [Char]
"threw exception: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show SomeException
exc
            forall e a. Exception e => e -> IO a
Exception.throwIO SomeException
exc

toSecs :: Thread.Seconds -> Double
toSecs :: Seconds -> Double
toSecs = forall a b. (Real a, Fractional b) => a -> b
realToFrac