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

-- | Functions to compare a performance against a previous \"known good\" one.
-- This is used to detect when code changes cause a performance to change.
module Cmd.DiffPerformance (
    -- * save and load
    load_midi, save_midi, midi_magic
    -- * diff
    , diff_lilypond
    , diff_im
    , diff_midi
    -- * util
    , show_midi
    , diff_lines
) where
import qualified Control.Exception as Exception
import qualified Data.List as List
import qualified Data.Text as Text
import qualified Data.Vector as Vector

import qualified System.Directory as Directory
import           System.FilePath ((</>))
import qualified System.IO.Error as IO.Error
import qualified System.Process as Process

import qualified Util.Files as Files
import qualified Util.Lists as Lists
import qualified Util.Serialize as Serialize

import qualified Midi.Encode as Encode
import           Midi.Instances ()
import qualified Midi.Midi as Midi

import qualified Perform.RealTime as RealTime
import qualified Synth.Shared.Note as Shared.Note
import qualified Ui.UiConfig as UiConfig

import           Global


type Messages = Vector.Vector Midi.WriteMessage

-- * save and load

load_midi :: FilePath -> IO (Either Text Messages)
load_midi :: [Char] -> IO (Either Text Messages)
load_midi [Char]
fname =
    forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (((Text
"loading " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt [Char]
fname forall a. Semigroup a => a -> a -> a
<> Text
": ") <>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Pretty a => a -> Text
pretty) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        forall a.
Serialize a =>
Magic a -> [Char] -> IO (Either UnserializeError a)
Serialize.unserialize Magic Messages
midi_magic [Char]
fname

-- | Perform the input score and save the midi msgs to the output file.
-- This creates the -perf files.
save_midi :: FilePath -> Messages -> IO ()
save_midi :: [Char] -> Messages -> IO ()
save_midi [Char]
fn = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Serialize a => Magic a -> [Char] -> a -> IO Bool
Serialize.serialize Magic Messages
midi_magic [Char]
fn

-- | Saved MIDI performance.
midi_magic :: Serialize.Magic (Vector.Vector Midi.WriteMessage)
midi_magic :: Magic Messages
midi_magic = forall {k} (a :: k). Char -> Char -> Char -> Char -> Magic a
Serialize.Magic Char
'm' Char
'i' Char
'd' Char
'i'


-- * diff

diff_lilypond :: String -> FilePath -> UiConfig.LilypondPerformance -> Text
    -> IO (Maybe Text, [FilePath])
diff_lilypond :: [Char]
-> [Char]
-> LilypondPerformance
-> Text
-> IO (Maybe Text, [[Char]])
diff_lilypond = forall events.
(events -> [Text])
-> [Char]
-> [Char]
-> Performance events
-> events
-> IO (Maybe Text, [[Char]])
diff_performance Text -> [Text]
Text.lines

diff_im :: String -> FilePath -> UiConfig.ImPerformance -> [Shared.Note.Note]
    -> IO (Maybe Text, [FilePath])
diff_im :: [Char]
-> [Char] -> ImPerformance -> [Note] -> IO (Maybe Text, [[Char]])
diff_im [Char]
name [Char]
dir ImPerformance
performance =
    forall events.
(events -> [Text])
-> [Char]
-> [Char]
-> Performance events
-> events
-> IO (Maybe Text, [[Char]])
diff_performance [Note] -> [Text]
show_im [Char]
name [Char]
dir (forall a. Vector a -> [a]
Vector.toList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImPerformance
performance)
    where show_im :: [Note] -> [Text]
show_im = forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Text
pretty

diff_midi :: String -> FilePath -> UiConfig.MidiPerformance
    -> [Midi.WriteMessage] -> IO (Maybe Text, [FilePath])
diff_midi :: [Char]
-> [Char]
-> MidiPerformance
-> [WriteMessage]
-> IO (Maybe Text, [[Char]])
diff_midi [Char]
name [Char]
dir MidiPerformance
performance =
    forall events.
(events -> [Text])
-> [Char]
-> [Char]
-> Performance events
-> events
-> IO (Maybe Text, [[Char]])
diff_performance [WriteMessage] -> [Text]
show_midi [Char]
name [Char]
dir (forall a. Vector a -> [a]
Vector.toList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MidiPerformance
performance)

diff_performance :: (events -> [Text]) -> String -> FilePath
    -> UiConfig.Performance events -> events -> IO (Maybe Text, [FilePath])
diff_performance :: forall events.
(events -> [Text])
-> [Char]
-> [Char]
-> Performance events
-> events
-> IO (Maybe Text, [[Char]])
diff_performance events -> [Text]
show_events [Char]
name [Char]
dir Performance events
performance events
events =
    forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text
info<>)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> [Char] -> [Text] -> [Text] -> IO (Maybe Text, [[Char]])
diff_lines [Char]
name [Char]
dir
        (events -> [Text]
show_events (forall a. Performance a -> a
UiConfig.perf_events Performance events
performance))
        (events -> [Text]
show_events events
events)
    where
    info :: Text
info = [Text] -> Text
Text.unlines
        [ Text
"Diffs from " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty (forall a. Performance a -> UTCTime
UiConfig.perf_creation Performance events
performance)
        , Text
"Commit: " forall a. Semigroup a => a -> a -> a
<> forall a. Performance a -> Text
UiConfig.perf_commit Performance events
performance
        ]

-- | Write files in the given directory and run the @diff@ command on them.
diff_lines :: String -> FilePath -> [Text] -> [Text]
    -> IO (Maybe Text, [FilePath])
    -- ^ (abbreviated_diff, wrote_files)
diff_lines :: [Char] -> [Char] -> [Text] -> [Text] -> IO (Maybe Text, [[Char]])
diff_lines [Char]
name [Char]
dir [Text]
expected [Text]
got = do
    Bool -> [Char] -> IO ()
Directory.createDirectoryIfMissing Bool
True [Char]
dir
    [Char] -> [Text] -> IO ()
Files.writeLines [Char]
expected_fn [Text]
expected
    [Char] -> [Text] -> IO ()
Files.writeLines [Char]
got_fn [Text]
got
    (ExitCode
_code, [Char]
diff, [Char]
stderr) <- [Char] -> [[Char]] -> [Char] -> IO (ExitCode, [Char], [Char])
Process.readProcessWithExitCode
        [Char]
"diff" [[Char]
expected_fn, [Char]
got_fn] [Char]
""
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
stderr) forall a b. (a -> b) -> a -> b
$
        forall e a. Exception e => e -> IO a
Exception.throwIO forall a b. (a -> b) -> a -> b
$ [Char] -> IOError
IO.Error.userError forall a b. (a -> b) -> a -> b
$ [Char]
"diff failed: " forall a. [a] -> [a] -> [a]
++ [Char]
stderr
    let abbreviated :: Maybe Text
abbreviated
            | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
diff = forall a. Maybe a
Nothing
            | Bool
otherwise = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text -> Text
show_diffs ([Char] -> Text
txt [Char]
diff)
    forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Text
abbreviated, [[Char]
expected_fn, [Char]
got_fn])
    where
    expected_fn :: [Char]
expected_fn = [Char]
dir [Char] -> [Char] -> [Char]
</> [Char]
name forall a. [a] -> [a] -> [a]
++ [Char]
".expected"
    got_fn :: [Char]
got_fn = [Char]
dir [Char] -> [Char] -> [Char]
</> [Char]
name forall a. [a] -> [a] -> [a]
++ [Char]
".got"

show_diffs :: Text -> Text
show_diffs :: Text -> Text
show_diffs Text
diff = [Text] -> Text
Text.unlines (Int -> [Text] -> [Text]
limit Int
50 (Text -> [Text]
Text.lines Text
diff))

limit :: Int -> [Text] -> [Text]
limit :: Int -> [Text] -> [Text]
limit Int
n [Text]
xs = [Text]
pre forall a. [a] -> [a] -> [a]
++ if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
post then [] else [Text
msg]
    where
    msg :: Text
msg = Text
"... trimmed (" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
xs) forall a. Semigroup a => a -> a -> a
<> Text
" lines)"
    ([Text]
pre, [Text]
post) = forall a. Int -> [a] -> ([a], [a])
splitAt Int
n [Text]
xs

show_midi :: [Midi.WriteMessage] -> [Text]
show_midi :: [WriteMessage] -> [Text]
show_midi = forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Text
pretty forall b c a. (b -> c) -> (a -> b) -> a -> c
. [WriteMessage] -> [WriteMessage]
normalize

-- | To better approximate audible differences, I strip excessive time
-- precision and ensure notes happening at the same time are in a consistent
-- order.
normalize :: [Midi.WriteMessage] -> [Midi.WriteMessage]
normalize :: [WriteMessage] -> [WriteMessage]
normalize = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a. Ord a => [a] -> [a]
List.sort forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall key a. Eq key => (a -> key) -> [a] -> [[a]]
Lists.groupAdjacent WriteMessage -> RealTime
Midi.wmsg_ts forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map WriteMessage -> WriteMessage
strip
    where
    strip :: WriteMessage -> WriteMessage
strip WriteMessage
wmsg = WriteMessage
wmsg
        { wmsg_ts :: RealTime
Midi.wmsg_ts = RealTime -> RealTime
strip_time (WriteMessage -> RealTime
Midi.wmsg_ts WriteMessage
wmsg)
        , wmsg_msg :: Message
Midi.wmsg_msg = Message -> Message
strip_msg (WriteMessage -> Message
Midi.wmsg_msg WriteMessage
wmsg)
        }
    -- It'll be rounded again by the pretty instance, since I actually diff
    -- pretty output, so this is likely unnecessary.
    strip_time :: RealTime -> RealTime
strip_time = Double -> RealTime
RealTime.seconds forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall d. RealFrac d => Int -> d -> d
round_to Int
3 forall b c a. (b -> c) -> (a -> b) -> a -> c
. RealTime -> Double
RealTime.to_seconds
    -- PitchBends are serialized as 14-bit numbers, so when they get
    -- deserialized they change.
    strip_msg :: Message -> Message
strip_msg = ByteString -> Message
Encode.decode forall b c a. (b -> c) -> (a -> b) -> a -> c
. Message -> ByteString
Encode.encode

round_to :: RealFrac d => Int -> d -> d
round_to :: forall d. RealFrac d => Int -> d -> d
round_to Int
n = (forall a. Fractional a => a -> a -> a
/ d
10forall a b. (Num a, Integral b) => a -> b -> a
^Int
n) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (RealFrac a, Integral b) => a -> b
round forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Num a => a -> a -> a
* d
10forall a b. (Num a, Integral b) => a -> b -> a
^Int
n)