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

{- | Helper functions to be imported into Cmd.Repl.Environ.  Cmd.Repl.Environ
    must be interpreted since it's the \"top level\" module, so I put the
    library of commands in here.  An unqualified import in Cmd.Repl.Environ
    means this module is in scope at the REPL.

    Of course, REPL commands can use anything in scope in Cmd.Repl.Environ, not
    just these helpers.  That includes all the various cmd_* functions used by
    the keybindings and everything in State.  Also, keybindings can be invoked
    directly with the 'keybinding' helper.  TODO not implemented

    Functions which are not designed to be composed generally take simpler
    types like strings, or get their block from the current focus, so they're
    easier to type.

    To keep this module from getting huge, only general purpose and common cmds
    should go here.  Cmds which are meant to be used from the REPL but may be
    more specialized can go in Cmd.Repl.L* modules.
-}
{-# LANGUAGE UndecidableInstances #-}
module Cmd.Repl.Global (
    module Cmd.Repl.Global, module Cmd.ModifyEvents
) where
import qualified Data.Map as Map

import qualified Util.Lists as Lists
import qualified Util.Pretty as Pretty
-- Just make sure these are compiled.
-- These are used to write patterns for 'ModifyEvents.substitute'.
import qualified App.ReplProtocol as ReplProtocol
import qualified Cmd.Cmd as Cmd
import qualified Cmd.Create as Create
import qualified Cmd.Info as Info
import           Cmd.ModifyEvents (Replacement(F), w, ws, ws1)
import           Cmd.Repl.LEvent ()
import           Cmd.Repl.LInst ()
import           Cmd.Repl.LPerf ()
import           Cmd.Repl.LPitch ()
import           Cmd.Repl.LRuler ()
import           Cmd.Repl.LTrack ()
import qualified Cmd.Save as Save
import qualified Cmd.Selection as Selection

import qualified Derive.Stack as Stack
import           Midi.Synth ()
import qualified Ui.Block as Block
import qualified Ui.Id as Id
import qualified Ui.Sel as Sel
import qualified Ui.Ui as Ui

import           Global
import           Types


-- | Take a string and automatically figure out what kind of ID is expected and
-- add a namespace if one was not already in the string.
--
-- Throws an error if the ID has bad characters, which is ok since this is
-- expected to be used from the REPL.
--
-- This is used by the REPL's macro feature, to replace @xyz@ with
-- (make_id "current-namespace" "xyz")
make_id :: Id.Ident a => Text -> Text -> a
make_id :: forall a. Ident a => Text -> Text -> a
make_id Text
ns Text
name =
    forall a. a -> Maybe a -> a
fromMaybe (forall a. Stack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"invalid characters in id: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Text
name) forall a b. (a -> b) -> a -> b
$
        forall a. Ident a => Id -> Maybe a
Id.make forall a b. (a -> b) -> a -> b
$ Namespace -> Text -> Id
Id.read_short (Text -> Namespace
Id.namespace Text
ns) Text
name

vid :: Text -> ViewId
vid :: Text -> ViewId
vid = Id -> ViewId
Id.ViewId forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Id
Id.read_id

bid :: Text -> BlockId
bid :: Text -> BlockId
bid = Id -> BlockId
Id.BlockId forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Id
Id.read_id

rid :: Text -> RulerId
rid :: Text -> RulerId
rid = Id -> RulerId
Id.RulerId forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Id
Id.read_id

tid :: Text -> TrackId
tid :: Text -> TrackId
tid = Id -> TrackId
Id.TrackId forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Id
Id.read_id

-- | Get the current focused block.
block :: Cmd.CmdL BlockId
block :: CmdL BlockId
block = forall (m :: * -> *). M m => m BlockId
Cmd.get_focused_block

-- | Get the track under the selection.
track :: Cmd.CmdL TrackId
track :: CmdL TrackId
track = do
    (BlockId
_, TrackNum
_, TrackId
track_id, TrackTime
_) <- forall (m :: * -> *).
M m =>
m (BlockId, TrackNum, TrackId, TrackTime)
Selection.get_insert
    forall (m :: * -> *) a. Monad m => a -> m a
return TrackId
track_id

tracknum :: Cmd.CmdL TrackNum
tracknum :: CmdL TrackNum
tracknum = do
    (BlockId
_, TrackNum
tracknum, TrackId
_, TrackTime
_) <- forall (m :: * -> *).
M m =>
m (BlockId, TrackNum, TrackId, TrackTime)
Selection.get_insert
    forall (m :: * -> *) a. Monad m => a -> m a
return TrackNum
tracknum

-- | Get the current focused view.
view :: Cmd.CmdL ViewId
view :: CmdL ViewId
view = forall (m :: * -> *). M m => m ViewId
Cmd.get_focused_view

-- | RulerId of the ruler under the selection.
ruler :: Cmd.CmdL RulerId
ruler :: CmdL RulerId
ruler = do
    TrackNum
n <- CmdL TrackNum
tracknum
    BlockId
block_id <- CmdL BlockId
block
    forall (m :: * -> *) a. M m => Maybe a -> m a
Cmd.abort_unless forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *).
M m =>
BlockId -> TrackNum -> m (Maybe RulerId)
Ui.ruler_track_at BlockId
block_id TrackNum
n

-- | Get the root block.
root :: Cmd.CmdL BlockId
root :: CmdL BlockId
root = forall (m :: * -> *). M m => m BlockId
Ui.get_root_id

-- | Create a namespace, and throw an IO exception if it has bad characters.
-- Intended to be used from the REPL, where throwing an IO exception is ok.
ns :: Text -> Id.Namespace
ns :: Text -> Namespace
ns Text
name
    | Text -> Bool
Id.valid_symbol Text
name = Text -> Namespace
Id.namespace Text
name
    | Bool
otherwise = forall a. Stack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"bad namespace: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Text
name

-- | Some oprators to more conveniently string together monadic and non-monadic
-- functions in the REPL.
--
-- For instance:
--
-- @
--      block >>= LPerf.get_midi_cache $> Midi.Cache.cache_chunks
--              .> (!!1) .> Midi.Cache.chunk_state .> Perform.state_postproc
-- @
($>) :: Functor f => f a -> (a -> b) -> f b
$> :: forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
($>) = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
(<$>)
infixl 1 $> -- put it above ($) but below everything else

-- | The REPL puts haskell in your sequencer, so you can compose while you
-- compose.
(.>) :: (a -> b) -> (b -> c) -> (a -> c)
.> :: forall a b c. (a -> b) -> (b -> c) -> a -> c
(.>) = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall b c a. (b -> c) -> (a -> b) -> a -> c
(.)
infixl 9 .>

-- | Pretty-print the result of a cmd with 'Pretty.format'.
pp :: Pretty a => Cmd.CmdL a -> Cmd.CmdL Text
pp :: forall a. Pretty a => CmdL a -> CmdL Text
pp = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Pretty a => a -> Text
Pretty.formatted

quit :: Cmd.CmdL ()
quit :: CmdL ()
quit = forall (m :: * -> *). M m => (State -> State) -> m ()
Cmd.modify forall a b. (a -> b) -> a -> b
$ \State
st -> State
st { state_repl_status :: Status
Cmd.state_repl_status = Status
Cmd.Quit }

-- * errors

-- | Called from logview
s :: String -> Cmd.CmdL ()
s :: String -> CmdL ()
s String
stackpos = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. (Stack, M m) => Text -> m a
Cmd.throw forall a b. (a -> b) -> a -> b
$ Text
"can't parse stackpos: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt String
stackpos)
    UiFrame -> CmdL ()
highlight_error (String -> Maybe UiFrame
Stack.parse_ui_frame String
stackpos)

-- | I used to use 'Config.error_selnum' for this, but it could be hard to
-- find.  Maybe the normal selection is more convenient, since I can zoom in on
-- it, or move it around to find it.
highlight_error :: Stack.UiFrame -> Cmd.CmdL ()
highlight_error :: UiFrame -> CmdL ()
highlight_error (Maybe BlockId
maybe_bid, Maybe TrackId
maybe_tid, Maybe (TrackTime, TrackTime)
maybe_range) = do
    BlockId
block_id <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe CmdL BlockId
find_block forall (m :: * -> *) a. Monad m => a -> m a
return Maybe BlockId
maybe_bid
    [ViewId]
view_ids <- forall k a. Map k a -> [k]
Map.keys forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => BlockId -> m (Map ViewId View)
Ui.views_of BlockId
block_id
    [ViewId]
view_ids <- if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ViewId]
view_ids then (forall a. a -> [a] -> [a]
:[]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => BlockId -> m ViewId
Create.view BlockId
block_id
        else forall (m :: * -> *) a. Monad m => a -> m a
return [ViewId]
view_ids
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *). M m => ViewId -> m ()
Cmd.focus [ViewId]
view_ids
    case (Maybe TrackId
maybe_tid, Maybe (TrackTime, TrackTime)
maybe_range) of
        (Maybe TrackId
Nothing, Maybe (TrackTime, TrackTime)
_) -> forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [ViewId]
view_ids forall a b. (a -> b) -> a -> b
$ \ViewId
vid ->
            forall (m :: * -> *). M m => ViewId -> Selection -> m ()
Selection.set_and_scroll ViewId
vid forall a b. (a -> b) -> a -> b
$ Sel.Selection
                { start_track :: TrackNum
start_track = TrackNum
0, start_pos :: TrackTime
start_pos = TrackTime
0
                , cur_track :: TrackNum
cur_track = TrackNum
9999, cur_pos :: TrackTime
cur_pos =  TrackTime
9999
                , orientation :: Orientation
orientation = Orientation
Sel.None
                }
        (Just TrackId
tid, Maybe (TrackTime, TrackTime)
Nothing) -> do
            TrackNum
tracknum <- forall (m :: * -> *). M m => BlockId -> TrackId -> m TrackNum
Ui.get_tracknum_of BlockId
block_id TrackId
tid
            forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [ViewId]
view_ids forall a b. (a -> b) -> a -> b
$ \ViewId
vid ->
                forall (m :: * -> *). M m => ViewId -> Selection -> m ()
Selection.set_and_scroll ViewId
vid forall a b. (a -> b) -> a -> b
$ Sel.Selection
                    { start_track :: TrackNum
start_track = TrackNum
tracknum, start_pos :: TrackTime
start_pos = TrackTime
0
                    , cur_track :: TrackNum
cur_track = TrackNum
tracknum, cur_pos :: TrackTime
cur_pos = TrackTime
9999
                    , orientation :: Orientation
orientation = Orientation
Sel.None
                    }
        (Just TrackId
tid, Just (TrackTime
from, TrackTime
to)) -> do
            TrackNum
tracknum <- forall (m :: * -> *). M m => BlockId -> TrackId -> m TrackNum
Ui.get_tracknum_of BlockId
block_id TrackId
tid
            forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [ViewId]
view_ids forall a b. (a -> b) -> a -> b
$ \ViewId
vid -> do
                forall (m :: * -> *). M m => ViewId -> Selection -> m ()
Selection.set_and_scroll ViewId
vid forall a b. (a -> b) -> a -> b
$ Sel.Selection
                    { start_track :: TrackNum
start_track = TrackNum
tracknum, start_pos :: TrackTime
start_pos = TrackTime
to
                    , cur_track :: TrackNum
cur_track = TrackNum
tracknum, cur_pos :: TrackTime
cur_pos = TrackTime
from
                    , orientation :: Orientation
orientation = Orientation
Sel.None
                    }
    where
    find_block :: CmdL BlockId
find_block = case Maybe TrackId
maybe_tid of
        Maybe TrackId
Nothing -> forall (m :: * -> *) a. (Stack, M m) => Text -> m a
Cmd.throw forall a b. (a -> b) -> a -> b
$
            Text
"can't highlight stack frame with neither block nor track: "
            forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt (Maybe BlockId
maybe_bid, Maybe TrackId
maybe_tid, Maybe (TrackTime, TrackTime)
maybe_range)
        Just TrackId
track_id -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. (Stack, M m) => Text -> m a
Cmd.throw forall a b. (a -> b) -> a -> b
$ Text
"no block with " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt TrackId
track_id)
            (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Maybe a
Lists.head forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *).
M m =>
TrackId -> m [(BlockId, [(TrackNum, TracklikeId)])]
Ui.blocks_with_track_id TrackId
track_id

-- * show / modify cmd state

show_history :: Cmd.CmdL Text
show_history :: CmdL Text
show_history = do
    History
hist <- forall (m :: * -> *) a. M m => (State -> a) -> m a
Cmd.gets State -> History
Cmd.state_history
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> Text
Pretty.formatted History
hist

-- * load / save

save :: Cmd.CmdL ()
save :: CmdL ()
save = CmdL ()
Save.save

-- | Save to the default filename and switch to saving plain states.
save_state :: Cmd.CmdL ()
save_state :: CmdL ()
save_state = CmdL ()
Save.save_state

-- | Save to the given filename and switch to saving plain states.
save_state_as :: FilePath -> Cmd.CmdL ()
save_state_as :: String -> CmdL ()
save_state_as = String -> CmdL ()
Save.save_state_as

-- | Like 'save_state', but don't change 'Cmd.state_save_file'.
write_state :: FilePath -> Cmd.CmdL FilePath
write_state :: String -> CmdL String
write_state = String -> CmdL String
Save.write_current_state

save_git :: Cmd.CmdL ()
save_git :: CmdL ()
save_git = CmdL ()
Save.save_git

-- | Save to the given git repo and switch to saving incrementally.
save_git_as :: FilePath -> Cmd.CmdL ()
save_git_as :: String -> CmdL ()
save_git_as = String -> CmdL ()
Save.save_git_as

load :: FilePath -> Cmd.CmdL ()
load :: String -> CmdL ()
load = String -> CmdL ()
Save.load

load_force :: FilePath -> Cmd.CmdL ()
load_force :: String -> CmdL ()
load_force = String -> CmdL ()
Save.load_force

revert :: Cmd.CmdL ()
revert :: CmdL ()
revert = Maybe String -> CmdL ()
Save.revert forall a. Maybe a
Nothing

revert_to :: String -> Cmd.CmdL ()
revert_to :: String -> CmdL ()
revert_to = Maybe String -> CmdL ()
Save.revert forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just

-- * called externally

collapse_track, expand_track :: BlockId -> TrackNum -> Cmd.CmdL ()
collapse_track :: BlockId -> TrackNum -> CmdL ()
collapse_track BlockId
block_id TrackNum
tracknum = do
    -- TODO if the track to collapse is a pitch track, merge it with its
    -- note track instead
    forall (m :: * -> *).
M m =>
BlockId -> TrackNum -> TrackFlag -> m ()
Ui.add_track_flag BlockId
block_id TrackNum
tracknum TrackFlag
Block.Collapse
    forall (m :: * -> *). M m => BlockId -> TrackNum -> m ()
Info.set_instrument_status BlockId
block_id TrackNum
tracknum
expand_track :: BlockId -> TrackNum -> CmdL ()
expand_track BlockId
block_id TrackNum
tracknum = do
    forall (m :: * -> *).
M m =>
BlockId -> TrackNum -> TrackFlag -> m ()
Ui.remove_track_flag BlockId
block_id TrackNum
tracknum TrackFlag
Block.Collapse
    forall (m :: * -> *). M m => BlockId -> TrackNum -> m ()
Info.set_instrument_status BlockId
block_id TrackNum
tracknum

-- | Called from logview.
collapse, expand :: TrackNum -> Cmd.CmdL ()
collapse :: TrackNum -> CmdL ()
collapse TrackNum
tracknum = forall a b c. (a -> b -> c) -> b -> a -> c
flip BlockId -> TrackNum -> CmdL ()
collapse_track TrackNum
tracknum forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). M m => m BlockId
Cmd.get_focused_block
expand :: TrackNum -> CmdL ()
expand TrackNum
tracknum = forall a b c. (a -> b -> c) -> b -> a -> c
flip BlockId -> TrackNum -> CmdL ()
expand_track TrackNum
tracknum forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). M m => m BlockId
Cmd.get_focused_block

-- | The result of a REPL Cmd is converted to a 'ReplProtocol.Result' with
-- this method.
class Return a where
    _to_result :: a -> ReplProtocol.Result
instance {-# OVERLAPPABLE #-} Show a => Return a where
    _to_result :: a -> Result
_to_result = Text -> Result
ReplProtocol.Format forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> Text
showt
instance Return ReplProtocol.Result where
    _to_result :: Result -> Result
_to_result = forall a. a -> a
id
instance Return Text where
    _to_result :: Text -> Result
_to_result = Text -> Result
ReplProtocol.Raw
instance Return String where
    _to_result :: String -> Result
_to_result = Text -> Result
ReplProtocol.Raw forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
txt
instance Return () where
    _to_result :: () -> Result
_to_result () = Text -> Result
ReplProtocol.Raw Text
""