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

-- | Utility to print out any of the binary formats used.
module App.Dump (main) where
import qualified Control.Monad.Except as Except
import qualified Data.Map as Map
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.Environment as Environment
import qualified System.IO as IO

import qualified Util.Git as Git
import qualified Util.Lists as Lists
import qualified Util.PPrint as PPrint
import qualified Util.Pretty as Pretty
import qualified Util.Processes as Processes
import qualified Util.Serialize as Serialize

import qualified Cmd.DiffPerformance as DiffPerformance
import qualified Cmd.SaveGit as SaveGit
import qualified Cmd.Serialize

import qualified Derive.Stack as Stack
import qualified Midi.Midi as Midi
import qualified Synth.Shared.Note
import qualified Ui.Block as Block
import qualified Ui.Event as Event
import qualified Ui.Events as Events
import qualified Ui.Track as Track
import qualified Ui.Ui as Ui
import qualified Ui.UiConfig as UiConfig

import           Global


data Mode = DumpAll | DumpAllocations | DumpConfig | DumpCalls
    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 -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Mode] -> ShowS
$cshowList :: [Mode] -> ShowS
show :: Mode -> String
$cshow :: Mode -> String
showsPrec :: Int -> Mode -> ShowS
$cshowsPrec :: Int -> Mode -> ShowS
Show)

data Flag = Mode !Mode | PPrint
    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 -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Flag] -> ShowS
$cshowList :: [Flag] -> ShowS
show :: Flag -> String
$cshow :: Flag -> String
showsPrec :: Int -> Flag -> ShowS
$cshowsPrec :: Int -> Flag -> ShowS
Show)

options :: [GetOpt.OptDescr Flag]
options :: [OptDescr Flag]
options =
    [ forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
GetOpt.Option [] [String
"allocations"] (forall a. a -> ArgDescr a
GetOpt.NoArg (Mode -> Flag
Mode Mode
DumpAllocations))
        String
"dump allocations"
    , forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
GetOpt.Option [] [String
"config"] (forall a. a -> ArgDescr a
GetOpt.NoArg (Mode -> Flag
Mode Mode
DumpConfig))
        String
"dump config"
    , forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
GetOpt.Option [] [String
"calls"] (forall a. a -> ArgDescr a
GetOpt.NoArg (Mode -> Flag
Mode Mode
DumpCalls))
        String
"Dump call text. Use this with grep to find where calls are used."
    , forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
GetOpt.Option [] [String
"pprint"] (forall a. a -> ArgDescr a
GetOpt.NoArg Flag
PPrint)
        String
"Use haskell pprint instead of Pretty."
    ]

usage_doc :: String
usage_doc :: String
usage_doc = String
"usage: dump file[,git-commit] file ..."

main :: IO ()
main :: IO ()
main = forall a. IO a -> IO a
Git.initialize forall a b. (a -> b) -> a -> b
$ do
    [String]
args <- IO [String]
Environment.getArgs
    ([Flag]
flags, [String]
args) <- case forall a.
ArgOrder a -> [OptDescr a] -> [String] -> ([a], [String], [String])
GetOpt.getOpt forall a. ArgOrder a
GetOpt.Permute [OptDescr Flag]
options [String]
args of
        ([Flag]
flags, [String]
args, []) -> forall (m :: * -> *) a. Monad m => a -> m a
return ([Flag]
flags, [String]
args)
        ([Flag]
_, [String]
_, [String]
errs) -> forall {b}. String -> IO b
usage forall a b. (a -> b) -> a -> b
$ String
"flag errors: " forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords [String]
errs
    let mode :: Mode
mode = forall a. a -> Maybe a -> a
fromMaybe Mode
DumpAll (forall a. [a] -> Maybe a
Lists.last [Mode
m | Mode Mode
m <- [Flag]
flags])
        pprint :: Bool
pprint = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Eq a => a -> a -> Bool
==Flag
PPrint) [Flag]
flags
    [Bool]
ok <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Bool -> Mode -> String -> IO Bool
dump_file Bool
pprint Mode
mode) [String]
args
    forall a. Int -> IO a
Processes.exit forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a. (a -> Bool) -> [a] -> [a]
filter Bool -> Bool
not [Bool]
ok)
    where
    usage :: String -> IO b
usage String
msg = do
        String -> IO ()
putStrLn String
usage_doc
        String -> IO ()
putStr (forall a. String -> [OptDescr a] -> String
GetOpt.usageInfo String
msg [OptDescr Flag]
options)
        forall a. Int -> IO a
Processes.exit Int
1

dump_file :: Bool -> Mode -> FilePath -> IO Bool
dump_file :: Bool -> Mode -> String -> IO Bool
dump_file Bool
pprint Mode
mode String
fname = Bool -> Mode -> String -> IO (Either Text [Text])
dump Bool
pprint Mode
mode String
fname forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Right [Text]
lines -> do
        let prefix :: Text
prefix = String -> Text
txt String
fname forall a. Semigroup a => a -> a -> a
<> Text
": "
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Text -> IO ()
Text.IO.putStrLn forall a b. (a -> b) -> a -> b
$
            if Mode
mode forall a. Eq a => a -> a -> Bool
== Mode
DumpCalls then forall a b. (a -> b) -> [a] -> [b]
map (Text
prefix<>) [Text]
lines else [Text]
lines
        forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    Left Text
err -> do
        Handle -> Text -> IO ()
Text.IO.hPutStrLn Handle
IO.stderr forall a b. (a -> b) -> a -> b
$ String -> Text
txt String
fname forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> Text
err
        forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

dump :: Bool -> Mode -> FilePath -> IO (Either Text [Text])
dump :: Bool -> Mode -> String -> IO (Either Text [Text])
dump Bool
pprint Mode
mode String
fname
    | [String
repo, String
commit] <- forall a. Eq a => NonNull a -> NonNull a -> NonNull (NonNull a)
Lists.split String
"," String
fname =
        Bool -> Mode -> String -> Maybe String -> IO (Either Text [Text])
dump_git Bool
pprint Mode
mode String
repo (forall a. a -> Maybe a
Just String
commit)
    | String -> Bool
SaveGit.is_git String
fname = Bool -> Mode -> String -> Maybe String -> IO (Either Text [Text])
dump_git Bool
pprint Mode
mode String
fname forall a. Maybe a
Nothing
dump Bool
pprint Mode
mode String
fname =
    forall a.
Serialize a =>
String
-> Magic a
-> (a -> [Text])
-> IO (Either Text [Text])
-> IO (Either Text [Text])
try String
fname Magic State
Cmd.Serialize.score_magic (Bool -> Mode -> State -> [Text]
dump_score Bool
pprint Mode
mode) forall a b. (a -> b) -> a -> b
$
    forall a.
Serialize a =>
String
-> Magic a
-> (a -> [Text])
-> IO (Either Text [Text])
-> IO (Either Text [Text])
try String
fname Magic Allocations
Cmd.Serialize.allocations_magic ((forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (Show a, Pretty a) => Bool -> a -> Text
format Bool
pprint) forall a b. (a -> b) -> a -> b
$
    forall a.
Serialize a =>
String
-> Magic a
-> (a -> [Text])
-> IO (Either Text [Text])
-> IO (Either Text [Text])
try String
fname Magic (Map ViewId View)
Cmd.Serialize.views_magic ((forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (Show a, Pretty a) => Bool -> a -> Text
format Bool
pprint) forall a b. (a -> b) -> a -> b
$
    forall a.
Serialize a =>
String
-> Magic a
-> (a -> [Text])
-> IO (Either Text [Text])
-> IO (Either Text [Text])
try String
fname Magic (Vector WriteMessage)
DiffPerformance.midi_magic Vector WriteMessage -> [Text]
dump_midi forall a b. (a -> b) -> a -> b
$
    forall a.
Serialize a =>
String
-> Magic a
-> (a -> [Text])
-> IO (Either Text [Text])
-> IO (Either Text [Text])
try String
fname Magic [Note]
Synth.Shared.Note.notesMagic (forall a b. (a -> b) -> [a] -> [b]
map (forall a. (Show a, Pretty a) => Bool -> a -> Text
format Bool
pprint)) forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left Text
"no magic codes match"

format :: (Show a, Pretty a) => Bool -> a -> Text
format :: forall a. (Show a, Pretty a) => Bool -> a -> Text
format Bool
pprint = if Bool
pprint then String -> Text
txt forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
PPrint.pshow else forall a. Pretty a => a -> Text
Pretty.formatted

-- | Try to unserialize the file, and try the passed continuation if it failed
-- with Serialize.BadMagic.
try :: Serialize.Serialize a => FilePath -> Serialize.Magic a
    -> (a -> [Text]) -> IO (Either Text [Text]) -> IO (Either Text [Text])
try :: forall a.
Serialize a =>
String
-> Magic a
-> (a -> [Text])
-> IO (Either Text [Text])
-> IO (Either Text [Text])
try String
fname Magic a
magic a -> [Text]
dump IO (Either Text [Text])
next = do
    Either UnserializeError a
val <- forall a.
Serialize a =>
Magic a -> String -> IO (Either UnserializeError a)
Serialize.unserialize Magic a
magic String
fname
    case Either UnserializeError a
val of
        Right a
val -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right (a -> [Text]
dump a
val)
        Left Serialize.BadMagic {} -> IO (Either Text [Text])
next
        Left UnserializeError
err -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left (forall a. Pretty a => a -> Text
pretty UnserializeError
err)

-- | Either a commit hash or a save point ref.
dump_git :: Bool -> Mode -> FilePath -> Maybe String -> IO (Either Text [Text])
dump_git :: Bool -> Mode -> String -> Maybe String -> IO (Either Text [Text])
dump_git Bool
pprint Mode
mode String
repo Maybe String
maybe_arg = forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
Except.runExceptT forall a b. (a -> b) -> a -> b
$ do
    Maybe Commit
maybe_commit <- case Maybe String
maybe_arg of
        Maybe String
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
        Just String
arg -> do
            Commit
commit <- forall e (m :: * -> *) a. MonadError e m => e -> Maybe a -> m a
tryJust (Text
"couldn't find commit for " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt String
arg)
                forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> String -> IO (Maybe Commit)
SaveGit.infer_commit String
repo String
arg)
            forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just Commit
commit)
    let prefix :: Text
prefix = Text
"reading " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt String
repo forall a. Semigroup a => a -> a -> a
<> Text
":"
    (State
state, Commit
commit, [Text]
names) <- forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
tryRight forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Text
prefix<>)
        forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> Maybe Commit -> IO (Either Text (State, Commit, [Text]))
SaveGit.load String
repo Maybe Commit
maybe_commit)
    let header :: Text
header = Text
"commit: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Commit
commit forall a. Semigroup a => a -> a -> a
<> Text
", names: "
            forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
", " [Text]
names
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text
header forall a. a -> [a] -> [a]
: Bool -> Mode -> State -> [Text]
dump_score Bool
pprint Mode
mode State
state

dump_score :: Bool -> Mode -> Ui.State -> [Text]
dump_score :: Bool -> Mode -> State -> [Text]
dump_score Bool
pprint Mode
mode State
state = case Mode
mode of
    Mode
DumpAll -> forall a. (Show a, Pretty a) => a -> [Text]
fmt State
state
    Mode
DumpAllocations -> forall a. (Show a, Pretty a) => a -> [Text]
fmt forall a b. (a -> b) -> a -> b
$
        Config -> Allocations
UiConfig.config_allocations forall a b. (a -> b) -> a -> b
$ State -> Config
Ui.state_config State
state
    Mode
DumpConfig -> forall a. (Show a, Pretty a) => a -> [Text]
fmt forall a b. (a -> b) -> a -> b
$ State -> Config
Ui.state_config State
state
    Mode
DumpCalls -> State -> [Text]
extract_calls State
state forall a. [a] -> [a] -> [a]
++ State -> [Text]
extract_event_text State
state
    where
    fmt :: (Show a, Pretty a) => a -> [Text]
    fmt :: forall a. (Show a, Pretty a) => a -> [Text]
fmt = (forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
strip_name forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (Show a, Pretty a) => Bool -> a -> Text
format Bool
pprint

dump_midi :: Vector.Vector Midi.WriteMessage -> [Text]
dump_midi :: Vector WriteMessage -> [Text]
dump_midi = forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Text
Pretty.formatted forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Vector a -> [a]
Vector.toList

-- | Remove the record name and dedent, since it's redundant.
strip_name :: Text -> Text
strip_name :: Text -> Text
strip_name Text
text = case Text -> [Text]
Text.lines Text
text of
    Text
name : Text
first : [Text]
rest | Text -> Bool
is_record Text
name ->
        -- +2 to drop the '{ ' and ', ' on each line.
        let indent :: Int
indent = Text -> Int
Text.length ((Char -> Bool) -> Text -> Text
Text.takeWhile (forall a. Eq a => a -> a -> Bool
==Char
' ') Text
first) forall a. Num a => a -> a -> a
+ Int
2
        in [Text] -> Text
Text.unlines forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Int -> Text -> Text
Text.drop Int
indent) (Text
first forall a. a -> [a] -> [a]
: [Text]
rest)
    [Text]
_ -> Text
text
    where
    is_record :: Text -> Bool
is_record = (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text
"State", Text
"Config"])

extract_calls :: Ui.State -> [Text]
extract_calls :: State -> [Text]
extract_calls State
state = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
Text.null) forall a b. (a -> b) -> a -> b
$
    Text -> Text -> Text
label Text
"ky" (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 a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (BlockId, Block) -> Text
block_title (forall k a. Map k a -> [(k, a)]
Map.toList (State -> Map BlockId Block
Ui.state_blocks State
state))
    forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map (TrackId, Track) -> Text
track_title (forall k a. Map k a -> [(k, a)]
Map.toList (State -> Map TrackId Track
Ui.state_tracks State
state))
    where
    block_title :: (BlockId, Block) -> Text
block_title (BlockId
block_id, Block
block) =
        UiFrame -> Text -> Text
stack_label (forall a. a -> Maybe a
Just BlockId
block_id, forall a. Maybe a
Nothing, forall a. Maybe a
Nothing) (Block -> Text
Block.block_title Block
block)
    track_title :: (TrackId, Track) -> Text
track_title (TrackId
track_id, Track
track) =
        UiFrame -> Text -> Text
stack_label (forall a. Maybe a
Nothing, forall a. a -> Maybe a
Just TrackId
track_id, forall a. Maybe a
Nothing) (Track -> Text
Track.track_title Track
track)

extract_event_text :: Ui.State -> [Text]
extract_event_text :: State -> [Text]
extract_event_text State
state =
    [ UiFrame -> Text -> Text
stack_label (forall {a} {a}.
a -> Event -> (Maybe a, Maybe a, Maybe (ScoreTime, ScoreTime))
frame TrackId
track_id Event
event) (Event -> Text
Event.text Event
event)
    | (TrackId
track_id, Track
track) <- forall k a. Map k a -> [(k, a)]
Map.toList (State -> Map TrackId Track
Ui.state_tracks State
state)
    , Event
event <- Events -> [Event]
Events.ascending (Track -> Events
Track.track_events Track
track)
    , Bool -> Bool
not (Text -> Bool
Text.null (Event -> Text
Event.text Event
event))
    ]
    where
    frame :: a -> Event -> (Maybe a, Maybe a, Maybe (ScoreTime, ScoreTime))
frame a
track_id Event
event =
        (forall a. Maybe a
Nothing, forall a. a -> Maybe a
Just a
track_id, forall a. a -> Maybe a
Just (Event -> (ScoreTime, ScoreTime)
Event.range Event
event))

stack_label :: Stack.UiFrame -> Text -> Text
stack_label :: UiFrame -> Text -> Text
stack_label UiFrame
frame = Text -> Text -> Text
label (UiFrame -> Text
Stack.log_ui_frame UiFrame
frame)

label :: Text -> Text -> Text
label :: Text -> Text -> Text
label Text
name Text
val
    | Text -> Bool
Text.null Text
val = Text
""
    | Bool
otherwise = Text
name forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> Text
val