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

-- | Cmdline program to verify that a saved score still derives the same MIDI
-- msgs or lilypond code as the last saved performance.
module App.VerifyPerformance (main) where
import qualified Control.Monad.Except as Except
import qualified Data.Aeson as Aeson
import qualified Data.ByteString.Lazy as ByteString.Lazy
import qualified Data.ByteString.Lazy.Char8 as ByteString.Lazy.Char8
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Maybe as Maybe
import qualified Data.Text as Text
import qualified Data.Text.IO as Text.IO
import qualified Data.Vector as Vector

import qualified System.Console.GetOpt as GetOpt
import qualified System.Directory as Directory
import qualified System.Environment
import qualified System.FilePath as FilePath
import           System.FilePath ((</>))
import qualified System.IO as IO

import qualified Util.Exceptions as Exceptions
import qualified Util.Git as Git
import qualified Util.Lists as Lists
import qualified Util.Log as Log
import qualified Util.Num as Num
import qualified Util.Pretty as Pretty
import qualified Util.Processes as Processes
import qualified Util.SourceControl as SourceControl
import qualified Util.Thread as Thread

import qualified Cmd.Cmd as Cmd
import qualified Cmd.DiffPerformance as DiffPerformance
import qualified Cmd.Save as Save

import qualified Derive.Derive as Derive
import qualified Derive.DeriveSaved as DeriveSaved
import qualified Derive.LEvent as LEvent
import qualified Derive.Score as Score

import qualified Midi.Midi as Midi
import qualified Perform.Im.Convert as Im.Convert
import qualified Synth.Shared.Note as Shared.Note
import qualified Ui.Ui as Ui
import qualified Ui.UiConfig as UiConfig

import           Global
import           Types


data Flag = Help | Mode Mode | Output !FilePath
    deriving (Flag -> Flag -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Flag -> Flag -> Bool
$c/= :: Flag -> Flag -> Bool
== :: Flag -> Flag -> Bool
$c== :: Flag -> Flag -> Bool
Eq, Int -> Flag -> ShowS
[Flag] -> ShowS
Flag -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Flag] -> ShowS
$cshowList :: [Flag] -> ShowS
show :: Flag -> [Char]
$cshow :: Flag -> [Char]
showsPrec :: Int -> Flag -> ShowS
$cshowsPrec :: Int -> Flag -> ShowS
Show)

data Mode =
    Verify | Save | Derive | Perform | Profile | ProfileDerive
    | DumpMidi | CommitInfo
    | UpdateMidi
    deriving (Mode -> Mode -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Mode -> Mode -> Bool
$c/= :: Mode -> Mode -> Bool
== :: Mode -> Mode -> Bool
$c== :: Mode -> Mode -> Bool
Eq, Int -> Mode -> ShowS
[Mode] -> ShowS
Mode -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Mode] -> ShowS
$cshowList :: [Mode] -> ShowS
show :: Mode -> [Char]
$cshow :: Mode -> [Char]
showsPrec :: Int -> Mode -> ShowS
$cshowsPrec :: Int -> Mode -> ShowS
Show, Mode
forall a. a -> a -> Bounded a
maxBound :: Mode
$cmaxBound :: Mode
minBound :: Mode
$cminBound :: Mode
Bounded, Int -> Mode
Mode -> Int
Mode -> [Mode]
Mode -> Mode
Mode -> Mode -> [Mode]
Mode -> Mode -> Mode -> [Mode]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Mode -> Mode -> Mode -> [Mode]
$cenumFromThenTo :: Mode -> Mode -> Mode -> [Mode]
enumFromTo :: Mode -> Mode -> [Mode]
$cenumFromTo :: Mode -> Mode -> [Mode]
enumFromThen :: Mode -> Mode -> [Mode]
$cenumFromThen :: Mode -> Mode -> [Mode]
enumFrom :: Mode -> [Mode]
$cenumFrom :: Mode -> [Mode]
fromEnum :: Mode -> Int
$cfromEnum :: Mode -> Int
toEnum :: Int -> Mode
$ctoEnum :: Int -> Mode
pred :: Mode -> Mode
$cpred :: Mode -> Mode
succ :: Mode -> Mode
$csucc :: Mode -> Mode
Enum)

data PerformTo = ToDerive | ToMidi
    deriving (PerformTo -> PerformTo -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PerformTo -> PerformTo -> Bool
$c/= :: PerformTo -> PerformTo -> Bool
== :: PerformTo -> PerformTo -> Bool
$c== :: PerformTo -> PerformTo -> Bool
Eq, Int -> PerformTo -> ShowS
[PerformTo] -> ShowS
PerformTo -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [PerformTo] -> ShowS
$cshowList :: [PerformTo] -> ShowS
show :: PerformTo -> [Char]
$cshow :: PerformTo -> [Char]
showsPrec :: Int -> PerformTo -> ShowS
$cshowsPrec :: Int -> PerformTo -> ShowS
Show)

options :: [GetOpt.OptDescr Flag]
options :: [OptDescr Flag]
options =
    [ forall a. [Char] -> [[Char]] -> ArgDescr a -> [Char] -> OptDescr a
GetOpt.Option [] [[Char]
"help"] (forall a. a -> ArgDescr a
GetOpt.NoArg Flag
Help) [Char]
"display usage"
    , forall a. [Char] -> [[Char]] -> ArgDescr a -> [Char] -> OptDescr a
GetOpt.Option [] [[Char]
"mode"]
        (forall a. ([Char] -> a) -> [Char] -> ArgDescr a
GetOpt.ReqArg [Char] -> Flag
read_mode (forall a. Show a => a -> [Char]
show [forall a. Bounded a => a
minBound :: Mode ..])) forall a b. (a -> b) -> a -> b
$
        [Char]
"Run in this mode, defaults to Verify.  Modes:\n\
        \Verify - Check saved performances against current performances.\n\
        \   If you give a directory and it has a file inside called\n\
        \   " forall a. [a] -> [a] -> [a]
++ [Char]
verify_me_txt forall a. [a] -> [a] -> [a]
++ [Char]
", use the contents of the file as\n\
        \   further files to verify.\n\
        \Save - Write saved performances to disk as binary.\n\
        \Perform - Perform to MIDI and write to $input.midi.\n\
        \Profile - Like Perform, but don't write any output.\n\
        \ProfileDerive - Like Profile, but derive only, don't render midi.\n\
        \DumpMidi - Pretty print binary saved MIDI to stdout.\n\
        \CommitInfo - Dump info on the current commit in JSON. This doesn't\n\
        \  belong here, but there's no other great place.\n\
        \UpdateMidi - Update the saved MIDI.\n"
    , forall a. [Char] -> [[Char]] -> ArgDescr a -> [Char] -> OptDescr a
GetOpt.Option [] [[Char]
"out"] (forall a. ([Char] -> a) -> [Char] -> ArgDescr a
GetOpt.ReqArg [Char] -> Flag
Output [Char]
default_out_dir) forall a b. (a -> b) -> a -> b
$
        [Char]
"Write output to this directory. This is diffs, and timing .json."
    ]

-- | This is intentionally not the same as what the shakefile uses, so I don't
-- mingle the results.
default_out_dir :: FilePath
default_out_dir :: [Char]
default_out_dir = [Char]
"build/verify-cmdline"

read_mode :: String -> Flag
read_mode :: [Char] -> Flag
read_mode [Char]
s =
    Mode -> Flag
Mode forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => [Char] -> a
error ([Char]
"unknown mode: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show [Char]
s)) forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup [Char]
s Map [Char] Mode
modes
    where modes :: Map [Char] Mode
modes = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(forall a. Show a => a -> [Char]
show Mode
m, Mode
m) | Mode
m <- [forall a. Bounded a => a
minBound .. forall a. Bounded a => a
maxBound]]

main :: IO ()
main :: IO ()
main = forall a. IO a -> IO a
Git.initialize forall a b. (a -> b) -> a -> b
$ do
    [[Char]]
args <- IO [[Char]]
System.Environment.getArgs
    (State -> State) -> IO ()
Log.configure forall a b. (a -> b) -> a -> b
$ \State
state -> State
state
        { state_priority :: Priority
Log.state_priority = Priority
Log.Warn
        , state_write_msg :: Msg -> IO ()
Log.state_write_msg = Handle -> Msg -> IO ()
Log.write_formatted Handle
IO.stderr
        }
    ([Flag]
flags, [[Char]]
args) <- case forall a.
ArgOrder a -> [OptDescr a] -> [[Char]] -> ([a], [[Char]], [[Char]])
GetOpt.getOpt forall a. ArgOrder a
GetOpt.Permute [OptDescr Flag]
options [[Char]]
args of
        ([Flag]
flags, [[Char]]
args, []) -> forall (m :: * -> *) a. Monad m => a -> m a
return ([Flag]
flags, [[Char]]
args)
        ([Flag]
_, [[Char]]
_, [[Char]]
errs) -> forall {b}. [Char] -> IO b
usage forall a b. (a -> b) -> a -> b
$ [Char]
"flag errors:\n" forall a. [a] -> [a] -> [a]
++ forall a. Monoid a => a -> [a] -> a
Lists.join [Char]
", " [[Char]]
errs
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Flag
Help | Flag
Help <- [Flag]
flags]) forall a b. (a -> b) -> a -> b
$ forall {b}. [Char] -> IO b
usage [Char]
""
    let out_dir :: [Char]
out_dir = forall a. a -> Maybe a -> a
fromMaybe [Char]
default_out_dir forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Maybe a
Lists.last [[Char]
d | Output [Char]
d <- [Flag]
flags]
    Config
cmd_config <- IO Config
DeriveSaved.load_cmd_config
    Int
failures <- case forall a. a -> Maybe a -> a
fromMaybe Mode
Verify forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Maybe a
Lists.last [Mode
m | Mode Mode
m <- [Flag]
flags] of
        Mode
Verify -> do
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
args) forall a b. (a -> b) -> a -> b
$ forall {b}. [Char] -> IO b
usage [Char]
"no inputs"
            [[Char]]
fnames <- forall (m :: * -> *) b a.
(Monad m, Monoid b) =>
(a -> m b) -> [a] -> m b
concatMapM [Char] -> IO [[Char]]
expand_verify_me [[Char]]
args
            [([Char], Int)]
results <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [[Char]]
fnames forall a b. (a -> b) -> a -> b
$ \[Char]
fname -> do
                [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ [Char]
"------------------------- verify " forall a. Semigroup a => a -> a -> a
<> [Char]
fname
                Int
fails <- ErrorM [Text] -> IO Int
run_error forall a b. (a -> b) -> a -> b
$ [Char] -> Config -> [Char] -> ErrorM [Text]
verify_performance [Char]
out_dir Config
cmd_config [Char]
fname
                [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ if Int
fails forall a. Eq a => a -> a -> Bool
== Int
0
                    then [Char]
"+++++++++++++++++++++++++ OK!"
                    else [Char]
"_________________________ FAILED!"
                forall (m :: * -> *) a. Monad m => a -> m a
return ([Char]
fname, Int
fails)
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Int
length [([Char], Int)]
results forall a. Ord a => a -> a -> Bool
> Int
1) forall a b. (a -> b) -> a -> b
$ do
                let ([([Char], Int)]
failed, [([Char], Int)]
ok) = forall a. (a -> Bool) -> [a] -> ([a], [a])
List.partition ((forall a. Ord a => a -> a -> Bool
>Int
0) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [([Char], Int)]
results
                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [([Char], Int)]
ok) forall a b. (a -> b) -> a -> b
$
                    [Char] -> IO ()
putStr forall a b. (a -> b) -> a -> b
$ [Char]
"    passed:\n" forall a. Semigroup a => a -> a -> a
<> [[Char]] -> [Char]
unlines (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [([Char], Int)]
ok)
                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [([Char], Int)]
failed) forall a b. (a -> b) -> a -> b
$
                    [Char] -> IO ()
putStr forall a b. (a -> b) -> a -> b
$ [Char]
"    failed:\n" forall a. Semigroup a => a -> a -> a
<> [[Char]] -> [Char]
unlines (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [([Char], Int)]
failed)
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
Num.sum forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [([Char], Int)]
results
        Mode
UpdateMidi -> do
            Int
_ <- ErrorM () -> IO Int
run_error0 forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Config -> [Char] -> ErrorM ()
update_midi Config
cmd_config) [[Char]]
args
            forall (m :: * -> *) a. Monad m => a -> m a
return Int
0
        Mode
Save -> do
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
args) forall a b. (a -> b) -> a -> b
$ forall {b}. [Char] -> IO b
usage [Char]
"no inputs"
            ErrorM [Text] -> IO Int
run_error forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat 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 ([Char] -> [Char] -> ErrorM [Text]
save [Char]
out_dir) [[Char]]
args
        Mode
Profile -> do
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
args) forall a b. (a -> b) -> a -> b
$ forall {b}. [Char] -> IO b
usage [Char]
"no inputs"
            ErrorM [Text] -> IO Int
run_error forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Maybe [Char] -> Config -> [Char] -> ErrorM ()
perform forall a. Maybe a
Nothing Config
cmd_config) [[Char]]
args forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return []
        Mode
ProfileDerive -> do
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
args) forall a b. (a -> b) -> a -> b
$ forall {b}. [Char] -> IO b
usage [Char]
"no inputs"
            ErrorM [Text] -> IO Int
run_error forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Maybe [Char] -> Config -> [Char] -> ErrorM (Vector Event, Seconds)
derive forall a. Maybe a
Nothing Config
cmd_config) [[Char]]
args forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return []
        Mode
Derive -> do
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
args) forall a b. (a -> b) -> a -> b
$ forall {b}. [Char] -> IO b
usage [Char]
"no inputs"
            ErrorM [Text] -> IO Int
run_error forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Maybe [Char] -> Config -> [Char] -> ErrorM (Vector Event, Seconds)
derive (forall a. a -> Maybe a
Just [Char]
out_dir) Config
cmd_config) [[Char]]
args
                forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return []
        Mode
Perform -> do
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
args) forall a b. (a -> b) -> a -> b
$ forall {b}. [Char] -> IO b
usage [Char]
"no inputs"
            ErrorM [Text] -> IO Int
run_error forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Maybe [Char] -> Config -> [Char] -> ErrorM ()
perform (forall a. a -> Maybe a
Just [Char]
out_dir) Config
cmd_config) [[Char]]
args
                forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return []
        Mode
DumpMidi -> do
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
args) forall a b. (a -> b) -> a -> b
$ forall {b}. [Char] -> IO b
usage [Char]
"no inputs"
            ErrorM [Text] -> IO Int
run_error forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ [Char] -> ErrorM ()
dump_midi [[Char]]
args forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return []
        Mode
CommitInfo -> do
            Entry
patch <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) a. (HasCallStack, MonadIO m) => Text -> m a
errorIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
txt) 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 [Char] Entry)
SourceControl.current [Char]
"."
            ByteString -> IO ()
ByteString.Lazy.Char8.putStrLn forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> ByteString
Aeson.encode forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
                [ (Text
"date" :: Text, forall a. ToJSON a => a -> Value
Aeson.toJSON forall a b. (a -> b) -> a -> b
$ Entry -> UTCTime
SourceControl._date Entry
patch)
                , (Text
"hash", forall a. ToJSON a => a -> Value
Aeson.toJSON forall a b. (a -> b) -> a -> b
$ Entry -> Text
SourceControl._hash Entry
patch)
                , (Text
"name", forall a. ToJSON a => a -> Value
Aeson.toJSON forall a b. (a -> b) -> a -> b
$ Entry -> Text
SourceControl._summary Entry
patch)
                ]
            forall (m :: * -> *) a. Monad m => a -> m a
return Int
0
    forall a. Int -> IO a
Processes.exit Int
failures
    where
    usage :: [Char] -> IO b
usage [Char]
msg = do
        [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ [Char]
"error: " forall a. [a] -> [a] -> [a]
++ [Char]
msg
        [Char] -> IO ()
putStrLn [Char]
"usage: verify_performance [ flags ] dirs or filenames"
        [Char] -> IO ()
putStr (forall a. [Char] -> [OptDescr a] -> [Char]
GetOpt.usageInfo [Char]
"" [OptDescr Flag]
options)
        forall a. Int -> IO a
Processes.exit Int
1

verify_me_txt :: FilePath
verify_me_txt :: [Char]
verify_me_txt = [Char]
"verify-me.txt"

-- | If this is a directory with a 'verify_me_txt', expand to include its
-- contents.
expand_verify_me :: FilePath -> IO [FilePath]
expand_verify_me :: [Char] -> IO [[Char]]
expand_verify_me [Char]
fname = do
    Maybe Text
m_contents <- forall a. IO a -> IO (Maybe a)
Exceptions.ignoreIOError forall a b. (a -> b) -> a -> b
$
        [Char] -> IO Text
Text.IO.readFile ([Char]
fname [Char] -> ShowS
</> [Char]
verify_me_txt)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Maybe Text
m_contents of
        Maybe Text
Nothing -> [[Char]
fname]
        Just Text
contents -> forall a b. (a -> b) -> [a] -> [b]
map (([Char]
fname</>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
untxt) forall a b. (a -> b) -> a -> b
$ Text -> [Text]
Text.lines Text
contents

type ErrorM a = Except.ExceptT Text IO a

run_error :: ErrorM [Text] -> IO Int
run_error :: ErrorM [Text] -> IO Int
run_error ErrorM [Text]
m = do
    [Text]
errors <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\Text
err -> forall (m :: * -> *) a. Monad m => a -> m a
return [Text
err]) forall (m :: * -> *) a. Monad m => a -> m a
return forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
Except.runExceptT ErrorM [Text]
m
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Text -> IO ()
Text.IO.putStrLn [Text]
errors
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
errors)

run_error0 :: ErrorM () -> IO Int
run_error0 :: ErrorM () -> IO Int
run_error0 ErrorM ()
m = forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
Except.runExceptT ErrorM ()
m forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left Text
err -> do
        Text -> IO ()
Text.IO.putStrLn Text
err
        forall (m :: * -> *) a. Monad m => a -> m a
return Int
1
    Right () -> forall (m :: * -> *) a. Monad m => a -> m a
return Int
0

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

-- * implementation

-- | Extract saved performances and write them to disk.
save :: FilePath -> FilePath -> ErrorM [Text]
save :: [Char] -> [Char] -> ErrorM [Text]
save [Char]
out_dir [Char]
fname = do
    (State
state, Builtins
_defs_lib, InstrumentAliases
_aliases, BlockId
block_id) <- [Char] -> ErrorM (State, Builtins, InstrumentAliases, BlockId)
load [Char]
fname
    let meta :: Meta
meta = Lens State Config
Ui.configforall a b c. Lens a b -> Lens b c -> Lens a c
#Config :-> Meta
UiConfig.meta forall f a. Lens f a -> f -> a
#$ State
state
        look :: Map BlockId a -> Maybe a
look = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup BlockId
block_id
    Bool
midi <- case forall {a}. Map BlockId a -> Maybe a
look (Meta -> Map BlockId MidiPerformance
UiConfig.meta_midi_performances Meta
meta) of
        Maybe MidiPerformance
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        Just MidiPerformance
perf -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
            [Char]
out <- [Char] -> [Char] -> [Char] -> IO [Char]
get_output [Char]
out_dir [Char]
fname [Char]
".midi"
            [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ [Char]
"write " forall a. Semigroup a => a -> a -> a
<> [Char]
out
            [Char] -> Messages -> IO ()
DiffPerformance.save_midi [Char]
out (forall a. Performance a -> a
UiConfig.perf_events MidiPerformance
perf)
            forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    Bool
ly <- case forall {a}. Map BlockId a -> Maybe a
look (Meta -> Map BlockId LilypondPerformance
UiConfig.meta_lilypond_performances Meta
meta) of
        Maybe LilypondPerformance
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        Just LilypondPerformance
perf -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
            [Char]
out <- [Char] -> [Char] -> [Char] -> IO [Char]
get_output [Char]
out_dir [Char]
fname [Char]
".midi"
            [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ [Char]
"write " forall a. Semigroup a => a -> a -> a
<> [Char]
out
            [Char] -> Text -> IO ()
Text.IO.writeFile [Char]
out (forall a. Performance a -> a
UiConfig.perf_events LilypondPerformance
perf)
            forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if Bool
midi Bool -> Bool -> Bool
|| Bool
ly then []
        else [[Char] -> Text
txt [Char]
fname forall a. Semigroup a => a -> a -> a
<> Text
": no midi or ly performance"]

-- | Perform to MIDI and possibly write to disk.
perform :: Maybe FilePath -> Cmd.Config -> FilePath -> ErrorM ()
perform :: Maybe [Char] -> Config -> [Char] -> ErrorM ()
perform Maybe [Char]
maybe_out_dir Config
cmd_config [Char]
fname = do
    (State
state, Builtins
library, InstrumentAliases
aliases, BlockId
block_id) <- [Char] -> ErrorM (State, Builtins, InstrumentAliases, BlockId)
load [Char]
fname
    ([WriteMessage]
msgs, Seconds
_, Seconds
_) <- [Char]
-> State
-> State
-> BlockId
-> ErrorM ([WriteMessage], Seconds, Seconds)
perform_block [Char]
fname
        (Builtins -> InstrumentAliases -> Config -> State
make_cmd_state Builtins
library InstrumentAliases
aliases Config
cmd_config) State
state BlockId
block_id
    forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe [Char]
maybe_out_dir forall a b. (a -> b) -> a -> b
$ \[Char]
out_dir -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
        [Char]
out <- [Char] -> [Char] -> [Char] -> IO [Char]
get_output [Char]
out_dir [Char]
fname [Char]
".midi"
        [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ [Char]
"write " forall a. Semigroup a => a -> a -> a
<> [Char]
out
        [Char] -> Messages -> IO ()
DiffPerformance.save_midi [Char]
out (forall a. [a] -> Vector a
Vector.fromList [WriteMessage]
msgs)

-- | Like 'perform', but don't perform to MIDI.
derive :: Maybe FilePath -> Cmd.Config -> FilePath
    -> ErrorM (Vector.Vector Score.Event, DeriveSaved.CPU)
derive :: Maybe [Char] -> Config -> [Char] -> ErrorM (Vector Event, Seconds)
derive Maybe [Char]
maybe_out_dir Config
cmd_config [Char]
fname = do
    (State
state, Builtins
library, InstrumentAliases
aliases, BlockId
block_id) <- [Char] -> ErrorM (State, Builtins, InstrumentAliases, BlockId)
load [Char]
fname
    let cmd_state :: State
cmd_state = Builtins -> InstrumentAliases -> Config -> State
make_cmd_state Builtins
library InstrumentAliases
aliases Config
cmd_config
    ((!Vector Event
events, [Msg]
logs), Seconds
derive_cpu) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
        [Char]
-> State -> State -> BlockId -> IO ((Vector Event, [Msg]), Seconds)
DeriveSaved.timed_derive [Char]
fname State
state State
cmd_state BlockId
block_id
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ 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. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Text -> IO ()
Text.IO.putStrLn forall a b. (a -> b) -> a -> b
$ Text
"derived " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt (forall a. Vector a -> Int
Vector.length Vector Event
events)
        forall a. Semigroup a => a -> a -> a
<> Text
" in " forall a. Semigroup a => a -> a -> a
<> forall a. RealFloat a => Int -> a -> Text
Num.showFloat Int
2 (Seconds -> Double
toSecs Seconds
derive_cpu)
    forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe [Char]
maybe_out_dir forall a b. (a -> b) -> a -> b
$ \[Char]
out_dir -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
        [Char]
out <- [Char] -> [Char] -> [Char] -> IO [Char]
get_output [Char]
out_dir [Char]
fname [Char]
".score"
        [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ [Char]
"write " forall a. Semigroup a => a -> a -> a
<> [Char]
out
        [Char] -> Text -> IO ()
Text.IO.writeFile [Char]
out forall a b. (a -> b) -> a -> b
$ [Text] -> Text
Text.unlines forall a b. (a -> b) -> a -> b
$
            forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Text
Pretty.formatted (forall a. Vector a -> [a]
Vector.toList Vector Event
events)
    forall (m :: * -> *) a. Monad m => a -> m a
return (Vector Event
events, Seconds
derive_cpu)

get_output :: FilePath -> FilePath -> String -> IO FilePath
get_output :: [Char] -> [Char] -> [Char] -> IO [Char]
get_output [Char]
out_dir [Char]
fname [Char]
extension = do
    Bool -> [Char] -> IO ()
Directory.createDirectoryIfMissing Bool
True (ShowS
FilePath.takeDirectory [Char]
out)
    forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
out
    where
    out :: [Char]
out = [Char]
out_dir [Char] -> ShowS
</> ShowS
basename [Char]
fname forall a. Semigroup a => a -> a -> a
<> [Char]
extension

dump_midi :: FilePath -> ErrorM ()
dump_midi :: [Char] -> ErrorM ()
dump_midi [Char]
fname = do
    Messages
msgs <- forall a. IO (Either Text a) -> ExceptT Text IO a
require_right forall a b. (a -> b) -> a -> b
$ [Char] -> IO (Either Text Messages)
DiffPerformance.load_midi [Char]
fname
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall a. Pretty a => a -> IO ()
Pretty.pprint (forall a. Vector a -> [a]
Vector.toList Messages
msgs)

type Timings = [(Text, Thread.Seconds)]

verify_performance :: FilePath -> Cmd.Config -> FilePath -> ErrorM [Text]
verify_performance :: [Char] -> Config -> [Char] -> ErrorM [Text]
verify_performance [Char]
out_dir Config
cmd_config [Char]
fname = do
    (State
ui_state, Builtins
library, InstrumentAliases
aliases, BlockId
block_id) <- [Char] -> ErrorM (State, Builtins, InstrumentAliases, BlockId)
load [Char]
fname
    let meta :: Meta
meta = Lens State Config
Ui.configforall a b c. Lens a b -> Lens b c -> Lens a c
#Config :-> Meta
UiConfig.meta forall f a. Lens f a -> f -> a
#$ State
ui_state
    let cmd_state :: State
cmd_state = Builtins -> InstrumentAliases -> Config -> State
make_cmd_state Builtins
library InstrumentAliases
aliases Config
cmd_config
    let verify1 :: ([Char]
 -> [Char] -> State -> State -> BlockId -> a -> m (Maybe a, [a]))
-> (Meta -> Map BlockId a) -> m (Maybe a, [a])
verify1 [Char]
-> [Char] -> State -> State -> BlockId -> a -> m (Maybe a, [a])
verify Meta -> Map BlockId a
field =
            forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Maybe a
Nothing, []))
                ([Char]
-> [Char] -> State -> State -> BlockId -> a -> m (Maybe a, [a])
verify [Char]
out_dir [Char]
fname State
cmd_state State
ui_state BlockId
block_id)
                (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup BlockId
block_id (Meta -> Map BlockId a
field Meta
meta))
    (Maybe Text
midi_err, [(Text, Seconds)]
midi_timings) <-
        forall {m :: * -> *} {a} {a} {a}.
Monad m =>
([Char]
 -> [Char] -> State -> State -> BlockId -> a -> m (Maybe a, [a]))
-> (Meta -> Map BlockId a) -> m (Maybe a, [a])
verify1 [Char]
-> [Char]
-> State
-> State
-> BlockId
-> MidiPerformance
-> ErrorM (Maybe Text, [(Text, Seconds)])
verify_midi Meta -> Map BlockId MidiPerformance
UiConfig.meta_midi_performances
    (Maybe Text
im_err, [(Text, Seconds)]
im_timings) <- forall {m :: * -> *} {a} {a} {a}.
Monad m =>
([Char]
 -> [Char] -> State -> State -> BlockId -> a -> m (Maybe a, [a]))
-> (Meta -> Map BlockId a) -> m (Maybe a, [a])
verify1 [Char]
-> [Char]
-> State
-> State
-> BlockId
-> ImPerformance
-> ErrorM (Maybe Text, [(Text, Seconds)])
verify_im Meta -> Map BlockId ImPerformance
UiConfig.meta_im_performances
    (Maybe Text
ly_err, [(Text, Seconds)]
ly_timings) <- forall {m :: * -> *} {a} {a} {a}.
Monad m =>
([Char]
 -> [Char] -> State -> State -> BlockId -> a -> m (Maybe a, [a]))
-> (Meta -> Map BlockId a) -> m (Maybe a, [a])
verify1 [Char]
-> [Char]
-> State
-> State
-> BlockId
-> LilypondPerformance
-> ErrorM (Maybe Text, [(Text, Seconds)])
verify_lilypond
        Meta -> Map BlockId LilypondPerformance
UiConfig.meta_lilypond_performances
    let timings :: [(Text, Seconds)]
timings = [(Text, Seconds)]
midi_timings forall a. [a] -> [a] -> [a]
++ [(Text, Seconds)]
im_timings forall a. [a] -> [a] -> [a]
++ [(Text, Seconds)]
ly_timings
    if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Text, Seconds)]
timings
        then forall (m :: * -> *) a. Monad m => a -> m a
return [Text
"no saved performances"]
        else do
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> [(Text, Seconds)] -> IO ()
write_timing ([Char]
out_dir [Char] -> ShowS
</> ShowS
basename [Char]
fname forall a. Semigroup a => a -> a -> a
<> [Char]
".json")
                [(Text, Seconds)]
timings
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
Maybe.catMaybes [Maybe Text
midi_err, Maybe Text
im_err, Maybe Text
ly_err]

update_midi :: Cmd.Config -> FilePath -> ErrorM ()
update_midi :: Config -> [Char] -> ErrorM ()
update_midi Config
cmd_config [Char]
fname = do
    (State
ui_state, Builtins
library, InstrumentAliases
aliases, BlockId
block_id) <- [Char] -> ErrorM (State, Builtins, InstrumentAliases, BlockId)
load [Char]
fname
    let cmd_state :: State
cmd_state = Builtins -> InstrumentAliases -> Config -> State
make_cmd_state Builtins
library InstrumentAliases
aliases Config
cmd_config
    ([WriteMessage]
msgs, Seconds
_, Seconds
_) <- [Char]
-> State
-> State
-> BlockId
-> ErrorM ([WriteMessage], Seconds, Seconds)
perform_block [Char]
fname State
cmd_state State
ui_state BlockId
block_id
    MidiPerformance
perf <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (Performance a)
UiConfig.make_performance (forall a. [a] -> Vector a
Vector.fromList [WriteMessage]
msgs)
    State
ui_state <- 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 :-> Meta
UiConfig.metaforall a b c. Lens a b -> Lens b c -> Lens a c
#Meta :-> Map BlockId MidiPerformance
UiConfig.midi_performances
            forall f a. Lens f a -> (a -> a) -> f -> f
%= forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert BlockId
block_id MidiPerformance
perf)
        State
ui_state
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> State -> IO ()
Save.write_state [Char]
fname State
ui_state

-- | Perform from the given state and compare it to the old MidiPerformance.
verify_midi :: FilePath -> FilePath -> Cmd.State -> Ui.State -> BlockId
    -> UiConfig.MidiPerformance -> ErrorM (Maybe Text, Timings)
verify_midi :: [Char]
-> [Char]
-> State
-> State
-> BlockId
-> MidiPerformance
-> ErrorM (Maybe Text, [(Text, Seconds)])
verify_midi [Char]
out_dir [Char]
fname State
cmd_state State
ui_state BlockId
block_id MidiPerformance
performance = do
    ([WriteMessage]
msgs, Seconds
derive_cpu, Seconds
perform_cpu) <-
        [Char]
-> State
-> State
-> BlockId
-> ErrorM ([WriteMessage], Seconds, Seconds)
perform_block [Char]
fname State
cmd_state State
ui_state BlockId
block_id
    (Maybe Text
maybe_diff, [[Char]]
wrote_files) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
        [Char]
-> [Char]
-> MidiPerformance
-> [WriteMessage]
-> IO (Maybe Text, [[Char]])
DiffPerformance.diff_midi (ShowS
basename [Char]
fname forall a. [a] -> [a] -> [a]
++ [Char]
".midi")
            [Char]
out_dir MidiPerformance
performance [WriteMessage]
msgs
    forall (m :: * -> *) a. Monad m => a -> m a
return
        ( (forall a. Semigroup a => a -> a -> a
<> (Text
"\nwrote " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
txt ([[Char]] -> [Char]
unwords [[Char]]
wrote_files))) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
maybe_diff
        , [(Text
"derive", Seconds
derive_cpu), (Text
"perform", Seconds
perform_cpu)]
        )

verify_im :: FilePath -> FilePath -> Cmd.State -> Ui.State -> BlockId
    -> UiConfig.ImPerformance -> ErrorM (Maybe Text, Timings)
verify_im :: [Char]
-> [Char]
-> State
-> State
-> BlockId
-> ImPerformance
-> ErrorM (Maybe Text, [(Text, Seconds)])
verify_im [Char]
out_dir [Char]
fname State
cmd_state State
ui_state BlockId
block_id ImPerformance
performance = do
    ((Vector Event
events, [Msg]
logs), Seconds
derive_cpu) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
        [Char]
-> State -> State -> BlockId -> IO ((Vector Event, [Msg]), Seconds)
DeriveSaved.timed_derive [Char]
fname State
ui_state State
cmd_state BlockId
block_id
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ 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
    let ([Note]
notes, [Msg]
convert_logs) = State -> State -> BlockId -> [Event] -> ([Note], [Msg])
convert_im State
cmd_state State
ui_state BlockId
block_id
            (forall a. Vector a -> [a]
Vector.toList Vector Event
events)
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ 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]
convert_logs
    (Maybe Text
maybe_diff, [[Char]]
wrote_files) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
        [Char]
-> [Char] -> ImPerformance -> [Note] -> IO (Maybe Text, [[Char]])
DiffPerformance.diff_im (ShowS
basename [Char]
fname forall a. [a] -> [a] -> [a]
++ [Char]
".im")
            [Char]
out_dir ImPerformance
performance [Note]
notes
    forall (m :: * -> *) a. Monad m => a -> m a
return
        ( (forall a. Semigroup a => a -> a -> a
<> (Text
"\nwrote " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
txt ([[Char]] -> [Char]
unwords [[Char]]
wrote_files))) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
maybe_diff
        , [(Text
"derive", Seconds
derive_cpu)]
        )

convert_im :: Cmd.State -> Ui.State -> BlockId -> [Score.Event]
    -> ([Shared.Note.Note], [Log.Msg])
convert_im :: State -> State -> BlockId -> [Event] -> ([Note], [Msg])
convert_im State
cmd_state State
ui_state BlockId
block_id [Event]
events =
    forall {a}. Either Text ([LEvent a], [Msg]) -> ([a], [Msg])
extract forall a b. (a -> b) -> a -> b
$ forall a. State -> State -> CmdId a -> Either Text (a, [Msg])
DeriveSaved.run_cmd State
ui_state State
cmd_state forall a b. (a -> b) -> a -> b
$ do
        Instrument -> Maybe ResolvedInstrument
lookup_inst <- forall (m :: * -> *).
M m =>
m (Instrument -> Maybe ResolvedInstrument)
Cmd.get_lookup_instrument
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ BlockId
-> (Instrument -> Maybe ResolvedInstrument)
-> [Event]
-> [LEvent Note]
Im.Convert.convert BlockId
block_id Instrument -> Maybe ResolvedInstrument
lookup_inst [Event]
events
    where
    extract :: Either Text ([LEvent a], [Msg]) -> ([a], [Msg])
extract (Left Text
err) = ([], [HasCallStack => Priority -> Maybe Stack -> Text -> Msg
Log.msg Priority
Log.Error forall a. Maybe a
Nothing Text
err])
    extract (Right ([LEvent a]
levents, [Msg]
logs)) = ([a]
events, [Msg]
logs forall a. [a] -> [a] -> [a]
++ [Msg]
perf_logs)
        where ([a]
events, [Msg]
perf_logs) = forall d. [LEvent d] -> ([d], [Msg])
LEvent.partition [LEvent a]
levents

perform_block :: FilePath -> Cmd.State -> Ui.State -> BlockId
    -> ErrorM ([Midi.WriteMessage], DeriveSaved.CPU, DeriveSaved.CPU)
perform_block :: [Char]
-> State
-> State
-> BlockId
-> ErrorM ([WriteMessage], Seconds, Seconds)
perform_block [Char]
fname State
cmd_state State
state BlockId
block_id = do
    ((Vector Event
events, [Msg]
logs), Seconds
derive_cpu) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
        [Char]
-> State -> State -> BlockId -> IO ((Vector Event, [Msg]), Seconds)
DeriveSaved.timed_derive [Char]
fname State
state State
cmd_state BlockId
block_id
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ 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
perform_cpu) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
        State
-> [Char]
-> State
-> Vector Event
-> IO (([WriteMessage], [Msg]), Seconds)
DeriveSaved.timed_perform State
cmd_state [Char]
fname State
state Vector Event
events
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ 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, Seconds
derive_cpu, Seconds
perform_cpu)

verify_lilypond :: FilePath -> FilePath -> Cmd.State -> Ui.State
    -> BlockId -> UiConfig.LilypondPerformance -> ErrorM (Maybe Text, Timings)
verify_lilypond :: [Char]
-> [Char]
-> State
-> State
-> BlockId
-> LilypondPerformance
-> ErrorM (Maybe Text, [(Text, Seconds)])
verify_lilypond [Char]
out_dir [Char]
fname State
cmd_state State
state BlockId
block_id LilypondPerformance
performance = do
    ((Either Msg Text
result, [Msg]
logs), Seconds
cpu) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
        [Char]
-> State
-> State
-> BlockId
-> IO ((Either Msg Text, [Msg]), Seconds)
DeriveSaved.timed_lilypond [Char]
fname State
state State
cmd_state BlockId
block_id
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ 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
    case Either Msg Text
result of
        Left Msg
err -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text
"error deriving: " forall a. Semigroup a => a -> a -> a
<> Msg -> Text
Log.format_msg Msg
err, [])
        Right Text
got -> do
            (Maybe Text
maybe_diff, [[Char]]
wrote_files) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
                [Char]
-> [Char]
-> LilypondPerformance
-> Text
-> IO (Maybe Text, [[Char]])
DiffPerformance.diff_lilypond (ShowS
basename [Char]
fname forall a. [a] -> [a] -> [a]
++ [Char]
".ly") [Char]
out_dir
                    LilypondPerformance
performance Text
got
            forall (m :: * -> *) a. Monad m => a -> m a
return
                ( (forall a. Semigroup a => a -> a -> a
<> (Text
"\nwrote " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
txt ([[Char]] -> [Char]
unwords [[Char]]
wrote_files))) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
maybe_diff
                , [(Text
"lilypond", Seconds
cpu)]
                )

-- * util

-- | Load a score and get its root block id.
load :: FilePath
    -> ErrorM (Ui.State, Derive.Builtins, Derive.InstrumentAliases, BlockId)
load :: [Char] -> ErrorM (State, Builtins, InstrumentAliases, BlockId)
load [Char]
fname = do
     (State
state, Builtins
builtins, InstrumentAliases
aliases) <- forall a. IO (Either Text a) -> ExceptT Text IO a
require_right forall a b. (a -> b) -> a -> b
$ [Char] -> IO (Either Text (State, Builtins, InstrumentAliases))
DeriveSaved.load_score [Char]
fname
     BlockId
block_id <- forall a. IO (Either Text a) -> ExceptT Text IO a
require_right forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ State -> Either Text BlockId
get_root State
state
     forall (m :: * -> *) a. Monad m => a -> m a
return (State
state, Builtins
builtins, InstrumentAliases
aliases, BlockId
block_id)

make_cmd_state :: Derive.Builtins -> Derive.InstrumentAliases -> Cmd.Config
    -> Cmd.State
make_cmd_state :: Builtins -> InstrumentAliases -> Config -> State
make_cmd_state Builtins
builtins InstrumentAliases
aliases Config
cmd_config =
    Builtins -> InstrumentAliases -> State -> State
DeriveSaved.add_library Builtins
builtins InstrumentAliases
aliases forall a b. (a -> b) -> a -> b
$ Config -> State
Cmd.initial_state Config
cmd_config

get_root :: Ui.State -> Either Text BlockId
get_root :: State -> Either Text BlockId
get_root State
state = forall err a. err -> Maybe a -> Either err a
justErr Text
"no root block" 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
state

basename :: FilePath -> FilePath
basename :: ShowS
basename = ShowS
FilePath.takeFileName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
List.dropWhileEnd (forall a. Eq a => a -> a -> Bool
==Char
'/')

write_timing :: FilePath -> Timings -> IO ()
write_timing :: [Char] -> [(Text, Seconds)] -> IO ()
write_timing [Char]
fname [(Text, Seconds)]
timings = [Char] -> ByteString -> IO ()
ByteString.Lazy.writeFile [Char]
fname forall a b. (a -> b) -> a -> b
$ (forall a. Semigroup a => a -> a -> a
<>ByteString
"\n") forall a b. (a -> b) -> a -> b
$
    forall a. ToJSON a => a -> ByteString
Aeson.encode forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Seconds -> Double
toSecs) [(Text, Seconds)]
timings

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