content: -- 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 ns name =
      fromMaybe (error $ "invalid characters in id: " ++ show name) $
          Id.make $ Id.read_short (Id.namespace ns) name
  
  vid :: Text -> ViewId
  vid = Id.ViewId . Id.read_id
  
  bid :: Text -> BlockId
  bid = Id.BlockId . Id.read_id
  
  rid :: Text -> RulerId
  rid = Id.RulerId . Id.read_id
  
  tid :: Text -> TrackId
  tid = Id.TrackId . Id.read_id
  
  -- | Get the current focused block.
  block :: Cmd.CmdL BlockId
  block = Cmd.get_focused_block
  
  -- | Get the track under the selection.
  track :: Cmd.CmdL TrackId
  track = do
      (_, _, track_id, _) <- Selection.get_insert
      return track_id
  
  tracknum :: Cmd.CmdL TrackNum
  tracknum = do
      (_, tracknum, _, _) <- Selection.get_insert
      return tracknum
  
  -- | Get the current focused view.
  view :: Cmd.CmdL ViewId
  view = Cmd.get_focused_view
  
  -- | RulerId of the ruler under the selection.
  ruler :: Cmd.CmdL RulerId
  ruler = do
      n <- tracknum
      block_id <- block
      Cmd.abort_unless =<< Ui.ruler_track_at block_id n
  
  -- | Get the root block.
  root :: Cmd.CmdL BlockId
  root = 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 name
      | Id.valid_symbol name = Id.namespace name
      | otherwise = error $ "bad namespace: " ++ show 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
  ($>) = flip (<$>)
  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)
  (.>) = flip (.)
  infixl 9 .>
  
  -- | Pretty-print the result of a cmd with 'Pretty.format'.
  pp :: Pretty a => Cmd.CmdL a -> Cmd.CmdL Text
  pp = fmap Pretty.formatted
  
  quit :: Cmd.CmdL ()
  quit = Cmd.modify $ \st -> st { Cmd.state_repl_status = Cmd.Quit }
  
  -- * errors
  
  -- | Called from logview
  s :: String -> Cmd.CmdL ()
  s stackpos = maybe (Cmd.throw $ "can't parse stackpos: " <> showt stackpos)
      highlight_error (Stack.parse_ui_frame 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 (maybe_bid, maybe_tid, maybe_range) = do
      block_id <- maybe find_block return maybe_bid
      view_ids <- Map.keys <$> Ui.views_of block_id
      view_ids <- if null view_ids then (:[]) <$> Create.view block_id
          else return view_ids
      mapM_ Cmd.focus view_ids
      case (maybe_tid, maybe_range) of
          (Nothing, _) -> forM_ view_ids $ \vid ->
              Selection.set_and_scroll vid $ Sel.Selection
                  { start_track = 0, start_pos = 0
                  , cur_track = 9999, cur_pos =  9999
                  , orientation = Sel.None
                  }
          (Just tid, Nothing) -> do
              tracknum <- Ui.get_tracknum_of block_id tid
              forM_ view_ids $ \vid ->
                  Selection.set_and_scroll vid $ Sel.Selection
                      { start_track = tracknum, start_pos = 0
                      , cur_track = tracknum, cur_pos = 9999
                      , orientation = Sel.None
                      }
          (Just tid, Just (from, to)) -> do
              tracknum <- Ui.get_tracknum_of block_id tid
              forM_ view_ids $ \vid -> do
                  Selection.set_and_scroll vid $ Sel.Selection
                      { start_track = tracknum, start_pos = to
                      , cur_track = tracknum, cur_pos = from
                      , orientation = Sel.None
                      }
      where
      find_block = case maybe_tid of
          Nothing -> Cmd.throw $
              "can't highlight stack frame with neither block nor track: "
              <> showt (maybe_bid, maybe_tid, maybe_range)
          Just track_id -> maybe (Cmd.throw $ "no block with " <> showt track_id)
              (return . fst) . Lists.head =<< Ui.blocks_with_track_id track_id
  
  -- * show / modify cmd state
  
  show_history :: Cmd.CmdL Text
  show_history = do
      hist <- Cmd.gets Cmd.state_history
      return $ Pretty.formatted hist
  
  -- * load / save
  
  save :: Cmd.CmdL ()
  save = Save.save
  
  -- | Save to the default filename and switch to saving plain states.
  save_state :: Cmd.CmdL ()
  save_state = Save.save_state
  
  -- | Save to the given filename and switch to saving plain states.
  save_state_as :: FilePath -> Cmd.CmdL ()
  save_state_as = Save.save_state_as
  
  -- | Like 'save_state', but don't change 'Cmd.state_save_file'.
  write_state :: FilePath -> Cmd.CmdL FilePath
  write_state = Save.write_current_state
  
  save_git :: Cmd.CmdL ()
  save_git = Save.save_git
  
  -- | Save to the given git repo and switch to saving incrementally.
  save_git_as :: FilePath -> Cmd.CmdL ()
  save_git_as = Save.save_git_as
  
  load :: FilePath -> Cmd.CmdL ()
  load = Save.load
  
  load_force :: FilePath -> Cmd.CmdL ()
  load_force = Save.load_force
  
  revert :: Cmd.CmdL ()
  revert = Save.revert Nothing
  
  revert_to :: String -> Cmd.CmdL ()
  revert_to = Save.revert . Just
  
  -- * called externally
  
  collapse_track, expand_track :: BlockId -> TrackNum -> Cmd.CmdL ()
  collapse_track block_id tracknum = do
      -- TODO if the track to collapse is a pitch track, merge it with its
      -- note track instead
      Ui.add_track_flag block_id tracknum Block.Collapse
      Info.set_instrument_status block_id tracknum
  expand_track block_id tracknum = do
      Ui.remove_track_flag block_id tracknum Block.Collapse
      Info.set_instrument_status block_id tracknum
  
  -- | Called from logview.
  collapse, expand :: TrackNum -> Cmd.CmdL ()
  collapse tracknum = flip collapse_track tracknum =<< Cmd.get_focused_block
  expand tracknum = flip expand_track tracknum =<< 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 = ReplProtocol.Format . showt
  instance Return ReplProtocol.Result where
      _to_result = id
  instance Return Text where
      _to_result = ReplProtocol.Raw
  instance Return String where
      _to_result = ReplProtocol.Raw . txt
  instance Return () where
      _to_result () = ReplProtocol.Raw ""
  