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

-- | Simple repl to talk to seq.
module App.Repl (main) where
import qualified Control.Concurrent as Concurrent
import qualified Control.Exception as Exception
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Text as Text
import qualified Data.Text.IO as Text.IO

import qualified System.Console.Haskeline as Haskeline
import qualified System.Directory as Directory
import qualified System.Environment
import qualified System.Exit as Exit
import qualified System.FilePath as FilePath
import qualified System.IO as IO
import qualified System.Posix.Temp as Posix.Temp
import qualified System.Process as Process

import qualified Util.Control as Control
import qualified Util.Exceptions as Exceptions
import qualified Util.Log as Log
import qualified Util.Network as Network
import qualified Util.PPrint as PPrint
import qualified Util.Pretty as Pretty
import qualified Util.Lists as Lists
import qualified Util.Thread as Thread

import qualified App.Config as Config
import qualified App.ReplProtocol as ReplProtocol
import qualified LogView.Tail as Tail

import           Global


repl_doc :: Text
repl_doc :: Text
repl_doc =
    Text
"Type a command to send it to the sequencer.  Everything in\n\
    \Cmd.Repl.Environ, Cmd.Repl.Global, and Local.Repl is in scope.\n\
    \^D to quit.\n\
    \\n\
    \The prompt will have the name of the currently loaded score.  It will be\n\
    \red if there is no connection to Karya.\n\
    \\n\
    \Line editing can be configured with ~/.haskeline, see haskeline docs\n\
    \for details.  Tab completion should work for function names, and\n\
    \filename completion within quotes.  History is saved per-score, so\n\
    \you should have access to previous commands run on this score.\n\
    \\n\
    \Some commands can open an editor on a text file, which is vim only for\n\
    \now.  Saving the file will send its contents back to Karya.  If you have\n\
    \an editor open, Karya will not want to quit, but if you force it to\n\
    \anyway, the editor will be killed and unsaved changes preserved in\n\
    \log/.\n\
    \\n\
    \Colon commands:\n"
    forall a. Semigroup a => a -> a -> a
<> Text
colon_doc

type Input a = Haskeline.InputT IO a

initial_settings :: Haskeline.Settings IO
initial_settings :: Settings IO
initial_settings = forall (m :: * -> *). MonadIO m => Settings m
Haskeline.defaultSettings
    { historyFile :: Maybe FilePath
Haskeline.historyFile = forall a. a -> Maybe a
Just FilePath
history_suffix
    , autoAddHistory :: Bool
Haskeline.autoAddHistory = Bool
True
    }

history_suffix :: FilePath
history_suffix :: FilePath
history_suffix = FilePath
".repl"

complete :: Network.Addr -> (String, String)
    -> IO (String, [Haskeline.Completion])
complete :: Addr -> (FilePath, FilePath) -> IO (FilePath, [Completion])
complete Addr
addr =
    forall (m :: * -> *).
Monad m =>
Maybe Char
-> FilePath
-> (FilePath -> m [Completion])
-> CompletionFunc m
-> CompletionFunc m
Haskeline.completeQuotedWord (forall a. a -> Maybe a
Just Char
'\\') FilePath
"\"" forall (m :: * -> *). MonadIO m => FilePath -> m [Completion]
Haskeline.listFiles
        (Addr -> (FilePath, FilePath) -> IO (FilePath, [Completion])
complete_identefier Addr
addr)
    -- Like ghci, complete filenames within quotes.  It's useful for save and
    -- load.

complete_identefier :: Network.Addr -> Haskeline.CompletionFunc IO
complete_identefier :: Addr -> (FilePath, FilePath) -> IO (FilePath, [Completion])
complete_identefier Addr
addr =
    forall (m :: * -> *).
Monad m =>
Maybe Char
-> FilePath -> (FilePath -> m [Completion]) -> CompletionFunc m
Haskeline.completeWord forall a. Maybe a
Nothing FilePath
word_break_chars FilePath -> IO [Completion]
complete
    where
    complete :: FilePath -> IO [Completion]
complete FilePath
prefix = do
        [Text]
words <- Addr -> Text -> IO [Text]
ReplProtocol.query_completion Addr
addr (FilePath -> Text
txt FilePath
prefix)
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> Completion
Haskeline.simpleCompletion forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
untxt) [Text]
words
    word_break_chars :: FilePath
word_break_chars = FilePath
" \t\n(),;[]`{}!#$%&*+/<=>?@\\^|-~"

main :: IO ()
main :: IO ()
main = forall a. IO a -> IO a
ReplProtocol.initialize forall a b. (a -> b) -> a -> b
$ do
    [FilePath]
args <- IO [FilePath]
System.Environment.getArgs
    Addr
addr <- case [FilePath]
args of
        [] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ FilePath -> Addr
Network.Unix FilePath
Config.repl_socket_name
        [FilePath
fn] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ FilePath -> Addr
Network.Unix FilePath
fn
        [FilePath]
_ -> forall (m :: * -> *) a. (Stack, MonadIO m) => Text -> m a
errorIO Text
"usage: repl [ unix-socket ]"
    -- I don't want to see "thread started" logs.
    (State -> State) -> IO ()
Log.configure forall a b. (a -> b) -> a -> b
$ \State
state -> State
state { state_priority :: Priority
Log.state_priority = Priority
Log.Notice }
    ThreadId
repl_thread <- IO ThreadId
Concurrent.myThreadId
    IO () -> IO ThreadId
Thread.start forall a b. (a -> b) -> a -> b
$ ThreadId -> IO ()
watch_for_quit ThreadId
repl_thread
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
putStrLn FilePath
"^D to quit"
    Addr -> Settings IO -> IO ()
repl Addr
addr forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). CompletionFunc m -> Settings m -> Settings m
Haskeline.setComplete (Addr -> (FilePath, FilePath) -> IO (FilePath, [Completion])
complete Addr
addr) Settings IO
initial_settings

-- | Watch the seq.log for state changes, and interrupt the repl to pick up the
-- new state.  Otherwise, it will only notice the change on the next time the
-- prompt comes up, which means the current cmd probably goes into the wrong
-- history.
--
-- This will abort any half-written entry, or any editor in progress, which
-- might be a problem.
watch_for_quit :: Concurrent.ThreadId -> IO ()
watch_for_quit :: ThreadId -> IO ()
watch_for_quit ThreadId
repl_thread = do
    FilePath
fname <- IO FilePath
Tail.log_filename
    forall {b}. Handle -> IO b
loop forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FilePath -> Maybe Integer -> IO Handle
Tail.open FilePath
fname (forall a. a -> Maybe a
Just Integer
0)
    where
    loop :: Handle -> IO b
loop Handle
hdl = do
        (Msg
msg, Handle
hdl) <- Handle -> IO (Msg, Handle)
Tail.tail Handle
hdl
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Msg -> Text
Log.msg_text Msg
msg forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text
Tail.starting_msg, Text
Tail.quitting_msg]) forall a b. (a -> b) -> a -> b
$
            forall e. Exception e => ThreadId -> e -> IO ()
Concurrent.throwTo ThreadId
repl_thread Interrupt
Haskeline.Interrupt
        Handle -> IO b
loop Handle
hdl

repl :: Network.Addr -> Haskeline.Settings IO -> IO ()
repl :: Addr -> Settings IO -> IO ()
repl Addr
addr Settings IO
settings = forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
Exception.mask forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore ->
    forall state a. state -> ((state -> a) -> state -> a) -> a
Control.loop1 Settings IO
settings forall a b. (a -> b) -> a -> b
$ \Settings IO -> IO ()
loop Settings IO
old_settings -> do
        Maybe (Maybe FilePath)
maybe_save_fname <- Addr -> IO (Maybe (Maybe FilePath))
ReplProtocol.query_save_file Addr
addr
        let (Bool
connection_error, Settings IO
settings) = case Maybe (Maybe FilePath)
maybe_save_fname of
                Maybe (Maybe FilePath)
Nothing -> (Bool
True, Settings IO
old_settings)
                Just Maybe FilePath
fname -> (,) Bool
False forall a b. (a -> b) -> a -> b
$ Settings IO
old_settings
                    { historyFile :: Maybe FilePath
Haskeline.historyFile =
                        forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe FilePath
"" Maybe FilePath
fname forall a. Semigroup a => a -> a -> a
<> FilePath
history_suffix
                    }
        -- I would rather replace the prompt in-place, but an interrupt will
        -- always output a newline.  I can't tell where this happens in the
        -- haskeline source, but it happens before the catch gets called, so I
        -- think there's no way to disable it.
        Status
status <- forall (m :: * -> *) a. MonadMask m => m a -> m a -> m a
Haskeline.handleInterrupt IO Status
catch forall a b. (a -> b) -> a -> b
$ forall a. IO a -> IO a
restore forall a b. (a -> b) -> a -> b
$
            forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
Settings m -> InputT m a -> m a
Haskeline.runInputT Settings IO
settings forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
InputT m a -> InputT m a
Haskeline.withInterrupt forall a b. (a -> b) -> a -> b
$
            Addr -> Bool -> Maybe FilePath -> InputT IO Status
read_eval_print Addr
addr Bool
connection_error
                (forall (m :: * -> *). Settings m -> Maybe FilePath
Haskeline.historyFile Settings IO
settings)
        Bool
continue <- case Status
status of
            Status
Continue -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
            Command Text
cmd -> do
                Status
status <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Addr -> Text -> IO Status
send_command Addr
addr Text
cmd
                case Status
status of
                    Status
Continue -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                    Command Text
cmd -> do
                        -- Or maybe I should just keep having this conversation?
                        FilePath -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ FilePath
"two Commands in a row: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> FilePath
show Text
cmd
                        forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                    Status
Quit -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
            Status
Quit -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
continue forall a b. (a -> b) -> a -> b
$ Settings IO -> IO ()
loop Settings IO
settings
    where
    read_eval_print :: Addr -> Bool -> Maybe FilePath -> InputT IO Status
read_eval_print Addr
addr Bool
connection_error Maybe FilePath
history =
        forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return Status
Quit) (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. Addr -> Maybe FilePath -> Text -> IO Status
eval Addr
addr Maybe FilePath
history forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
Text.strip)
            forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Bool -> Maybe FilePath -> Input (Maybe Text)
get_input Bool
connection_error Maybe FilePath
history
    catch :: IO Status
catch = forall (m :: * -> *) a. Monad m => a -> m a
return Status
Continue

eval :: Network.Addr -> Maybe FilePath -> Text -> IO Status
eval :: Addr -> Maybe FilePath -> Text -> IO Status
eval Addr
addr Maybe FilePath
maybe_history Text
expr = case Text -> Text -> Maybe Text
Text.stripPrefix Text
":" (Text -> Text
Text.toLower Text
expr) of
    Just Text
"h" -> case Maybe FilePath
maybe_history of
        Maybe FilePath
Nothing -> FilePath -> IO ()
putStrLn FilePath
"no history to edit" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Status
Continue
        Just FilePath
history -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return Status
Continue) (Addr -> Text -> IO Status
send_command Addr
addr)
            forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FilePath -> IO (Maybe Text)
edit_line FilePath
history
    Just Text
"r" -> Addr -> Text -> IO Status
send_command Addr
addr Text
":reload" -- reload handled in ReplGhc
    Just Text
"?" -> Text -> IO ()
Text.IO.putStr Text
repl_doc forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Status
Continue
    Just Text
_ -> do
        FilePath -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ FilePath
"unknown colon command " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> FilePath
show Text
expr forall a. Semigroup a => a -> a -> a
<> FilePath
", :? for help"
        forall (m :: * -> *) a. Monad m => a -> m a
return Status
Continue
    Maybe Text
_ -> Addr -> Text -> IO Status
send_command Addr
addr Text
expr

colon_doc :: Text
colon_doc :: Text
colon_doc =
    Text
":? - Help.\n\
    \:h - Open an editor on the history.  You can find a line, edit it, and\n\
    \     use ZZ to write it back.\n\
    \:r - Reload modified modules.  Only modify \"surface\" modules, e.g.\n\
    \    ones in Cmd/Repl/, since the GHC API tends to crash if you make it\n\
    \    reload too much.  Maybe it crashes if it has to reload something\n\
    \    with a C dependency.\n"

send_command :: Network.Addr -> Text -> IO Status
send_command :: Addr -> Text -> IO Status
send_command Addr
addr Text
expr
    | Text -> Bool
Text.null Text
expr = forall (m :: * -> *) a. Monad m => a -> m a
return Status
Continue
    | Bool
otherwise = do
        CmdResult
result <- Addr -> Text -> IO CmdResult
ReplProtocol.query_cmd Addr
addr (Text -> Text
Text.strip Text
expr)
        Result
result <- CmdResult -> IO Result
print_logs CmdResult
result
        Addr -> Result -> IO Status
handle_result Addr
addr Result
result

handle_result :: Network.Addr -> ReplProtocol.Result -> IO Status
handle_result :: Addr -> Result -> IO Status
handle_result Addr
addr = \case
    ReplProtocol.Raw Text
text -> do
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text -> Bool
Text.null (Text -> Text
Text.strip Text
text)) forall a b. (a -> b) -> a -> b
$
            Text -> IO ()
Text.IO.putStrLn (Text -> Text
Text.stripEnd Text
text)
        forall (m :: * -> *) a. Monad m => a -> m a
return Status
Continue
    ReplProtocol.Format Text
text -> do
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text -> Bool
Text.null (Text -> Text
Text.strip Text
text)) forall a b. (a -> b) -> a -> b
$
            FilePath -> IO ()
putStr forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
PPrint.format_str forall a b. (a -> b) -> a -> b
$ Text -> FilePath
untxt Text
text
        forall (m :: * -> *) a. Monad m => a -> m a
return Status
Continue
    ReplProtocol.Edit NonEmpty Editor
editors -> do
        Addr -> NotifySeq -> IO (Either IOException ())
ReplProtocol.notify Addr
addr NotifySeq
ReplProtocol.NEditorOpened
        NonEmpty Editor -> IO ()
edit_multiple NonEmpty Editor
editors
        Addr -> NotifySeq -> IO (Either IOException ())
ReplProtocol.notify Addr
addr NotifySeq
ReplProtocol.NEditorClosed
        forall (m :: * -> *) a. Monad m => a -> m a
return Status
Continue

print_logs :: ReplProtocol.CmdResult -> IO ReplProtocol.Result
print_logs :: CmdResult -> IO Result
print_logs (ReplProtocol.CmdResult Result
val [Msg]
logs_) = do
    -- Filter Debug logs, otherwise I get spammed with cache msgs.
    let logs :: [Msg]
logs = forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Ord a => a -> a -> Bool
>Priority
Log.Debug) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Msg -> Priority
Log.msg_priority) forall a b. (a -> b) -> a -> b
$
            [Msg] -> [Msg]
ReplProtocol.abbreviate_package_loads [Msg]
logs_
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Msg]
logs) forall a b. (a -> b) -> a -> b
$ do
        FilePath -> IO ()
putStrLn FilePath
"Logs:"
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall a. Pretty a => a -> IO ()
Pretty.pprint [Msg]
logs
        Char -> IO ()
putChar Char
'\n'
    forall (m :: * -> *) a. Monad m => a -> m a
return Result
val

get_input :: Bool -> Maybe FilePath -> Input (Maybe Text)
get_input :: Bool -> Maybe FilePath -> Input (Maybe Text)
get_input Bool
connection_error Maybe FilePath
history =
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> Text
Text.strip forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
txt) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
FilePath -> InputT m (Maybe FilePath)
Haskeline.getInputLine (Bool -> Maybe FilePath -> FilePath
prompt Bool
connection_error Maybe FilePath
history)

data Status = Continue
    -- | Skip the next prompt and send this as a QCommand.
    | Command !Text
    -- | Blow this popsicle stand.
    | Quit deriving (Int -> Status -> FilePath -> FilePath
[Status] -> FilePath -> FilePath
Status -> FilePath
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [Status] -> FilePath -> FilePath
$cshowList :: [Status] -> FilePath -> FilePath
show :: Status -> FilePath
$cshow :: Status -> FilePath
showsPrec :: Int -> Status -> FilePath -> FilePath
$cshowsPrec :: Int -> Status -> FilePath -> FilePath
Show)

-- | Colorize the prompt to make it stand out.
prompt :: Bool -> Maybe FilePath -> String
prompt :: Bool -> Maybe FilePath -> FilePath
prompt Bool
connection_error Maybe FilePath
maybe_save =
    forall a. Monoid a => [a] -> a
mconcat [FilePath
save,  FilePath
color_bg,  FilePath
stx,  FilePath
"入",  FilePath
plain_bg,  FilePath
stx,  FilePath
" "]
    where
    color_bg :: FilePath
color_bg = if Bool
connection_error then FilePath
red_bg else FilePath
cyan_bg
    save :: FilePath
save = forall b a. b -> (a -> b) -> Maybe a -> b
maybe FilePath
"" (forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => [a] -> [a] -> ([a], Bool)
Lists.dropSuffix FilePath
".repl" forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
FilePath.takeFileName)
        Maybe FilePath
maybe_save
    -- The trailing \STX tells haskeline this is a control sequence, from
    -- http://trac.haskell.org/haskeline/wiki/ControlSequencesInPrompt
    stx :: FilePath
stx = FilePath
"\STX"

cyan_bg :: String
cyan_bg :: FilePath
cyan_bg = FilePath
"\ESC[46m"

red_bg :: String
red_bg :: FilePath
red_bg = FilePath
"\ESC[41m"

plain_bg :: String
plain_bg :: FilePath
plain_bg = FilePath
"\ESC[39;49m"


-- * editor

-- | Edit multiple files, each with their own vim config.  This blocks until
-- the editor exits.
--
-- The technique is to make a file of vim commands that edits each file and
-- runs commands in turn.
--
-- TODO currently only vim is supported, but I assume other editors could also
-- be press-ganged into similar service.
edit_multiple :: NonEmpty ReplProtocol.Editor -> IO ()
edit_multiple :: NonEmpty Editor -> IO ()
edit_multiple NonEmpty Editor
edits_ = forall a. [File] -> ([FilePath] -> IO a) -> IO a
with_files (forall a b. (a -> b) -> [a] -> [b]
map Editor -> File
ReplProtocol._file [Editor]
edits) forall a b. (a -> b) -> a -> b
$ \[FilePath]
fnames ->
    forall a.
FilePath -> FilePath -> Text -> (FilePath -> IO a) -> IO a
with_temp FilePath
"repl-cmds-" FilePath
".vim" ([FilePath] -> Text
make_cmds [FilePath]
fnames) forall a b. (a -> b) -> a -> b
$ \FilePath
cmd_fname -> do
        Bool
ok <- FilePath -> [FilePath] -> IO Bool
wait_for_command FilePath
"vim"
            [ FilePath
"-s", FilePath
cmd_fname
            , FilePath
"-c", FilePath
"source vim-functions.vim"
            -- Put the swp file in the log/ directory.  Otherwise it's in a tmp
            -- dir and dies when it does.  This is just paranoia, if vim happens
            -- to get killed with unsaved data (say due to 'watch_for_quit'),
            -- then it can be recovered.
            , FilePath
"-c", FilePath
":set directory=log"
            ]
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
ok forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a b. [a] -> [b] -> [(a, b)]
zip [FilePath]
fnames (forall a b. (a -> b) -> [a] -> [b]
map Editor -> Maybe Text
ReplProtocol._on_save [Editor]
edits)) forall a b. (a -> b) -> a -> b
$ \case
            (FilePath
fname, Just Text
on_save) -> FilePath -> Text -> IO ()
send_file FilePath
fname Text
on_save
            (FilePath, Maybe Text)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        forall (m :: * -> *) a. Monad m => a -> m a
return ()
    where
    edits :: [Editor]
edits = forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty Editor
edits_
    make_cmds :: [FilePath] -> Text
make_cmds [FilePath]
fnames = [Text] -> Text
Text.unlines forall a b. (a -> b) -> a -> b
$
        forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (FilePath, Editor) -> [Text]
edit_cmds (forall a b. [a] -> [b] -> [(a, b)]
zip [FilePath]
fnames [Editor]
edits) forall a. [a] -> [a] -> [a]
++ [Text
":buffer 1"]
    edit_cmds :: (FilePath, Editor) -> [Text]
edit_cmds (FilePath
fname, ReplProtocol.Editor File
_ Int
linenum Maybe Text
on_save Maybe Text
on_send) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ [ Text
":edit " forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
txt FilePath
fname]
        , [Text
":" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Int
linenum]
        , [ Text
":nmap <buffer> gz :call Send('" forall a. Semigroup a => a -> a -> a
<> Text
c forall a. Semigroup a => a -> a -> a
<> Text
"')<cr>"
          | Just Text
c <- [Maybe Text
on_save]
          ]
        , [ Text
":nmap <buffer> gs :call Send('" forall a. Semigroup a => a -> a -> a
<> Text
c forall a. Semigroup a => a -> a -> a
<> Text
"')<cr>"
          | Just Text
c <- [Maybe Text
on_send]
          ]
        ]

with_files :: [ReplProtocol.File] -> ([FilePath] -> IO a) -> IO a
with_files :: forall a. [File] -> ([FilePath] -> IO a) -> IO a
with_files [File]
files [FilePath] -> IO a
action = [FilePath] -> [File] -> IO a
go [] [File]
files
    where
    go :: [FilePath] -> [File] -> IO a
go [FilePath]
accum [] = [FilePath] -> IO a
action (forall a. [a] -> [a]
reverse [FilePath]
accum)
    go [FilePath]
accum (ReplProtocol.FileName FilePath
fname : [File]
files) = [FilePath] -> [File] -> IO a
go (FilePath
fnameforall a. a -> [a] -> [a]
:[FilePath]
accum) [File]
files
    go [FilePath]
accum (ReplProtocol.Text FileType
ftype Text
content : [File]
files) = do
        let ext :: FilePath
ext = FileType -> FilePath
ReplProtocol.file_type_extension FileType
ftype
        forall a.
FilePath -> FilePath -> Text -> (FilePath -> IO a) -> IO a
with_temp FilePath
"repl-" FilePath
ext Text
content forall a b. (a -> b) -> a -> b
$ \FilePath
fname -> [FilePath] -> [File] -> IO a
go (FilePath
fnameforall a. a -> [a] -> [a]
:[FilePath]
accum) [File]
files

send_binary :: FilePath
send_binary :: FilePath
send_binary = FilePath
"build/opt/send"

send_file :: FilePath -> Text -> IO ()
send_file :: FilePath -> Text -> IO ()
send_file FilePath
fname Text
cmd = do
    -- The 'send' cmd substitutes stdin for %s.
    Text
content <- if Text
"%s" Text -> Text -> Bool
`Text.isInfixOf` Text
cmd
        -- vim will add a final newline.
        then Text -> Text
Text.stripEnd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO Text
Text.IO.readFile FilePath
fname
        else forall (m :: * -> *) a. Monad m => a -> m a
return Text
""
    -- Sometimes I forget to build it and it's annoying to crash the REPL.
    forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (FilePath -> IO Bool
Directory.doesFileExist FilePath
send_binary) forall a b. (a -> b) -> a -> b
$
        FilePath -> [FilePath] -> IO ()
Process.callProcess FilePath
"bin/mk" [FilePath
send_binary]
    FilePath
stdout <- FilePath -> [FilePath] -> FilePath -> IO FilePath
Process.readProcess FilePath
send_binary [Text -> FilePath
untxt Text
cmd]
        (Text -> FilePath
untxt Text
content)
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
stdout) forall a b. (a -> b) -> a -> b
$
        FilePath -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ FilePath
"send: " forall a. Semigroup a => a -> a -> a
<> FilePath
stdout

-- | Run the action with a temp file, and delete it afterwards.
with_temp :: FilePath -> String -> Text -> (FilePath -> IO a) -> IO a
with_temp :: forall a.
FilePath -> FilePath -> Text -> (FilePath -> IO a) -> IO a
with_temp FilePath
prefix FilePath
suffix Text
contents FilePath -> IO a
action = do
    -- .ky prefix so the vim autocmds will fire.
    (FilePath
path, Handle
hdl) <- FilePath -> FilePath -> IO (FilePath, Handle)
Posix.Temp.mkstemps FilePath
prefix FilePath
suffix
    Handle -> Text -> IO ()
Text.IO.hPutStr Handle
hdl Text
contents
    Handle -> IO ()
IO.hClose Handle
hdl
    FilePath -> IO a
action FilePath
path
        forall a b. IO a -> IO b -> IO a
`Exception.finally` forall a. IO a -> IO (Maybe a)
Exceptions.ignoreEnoent (FilePath -> IO ()
Directory.removeFile FilePath
path)

-- | Open the given file, and return the selected line.
edit_line :: FilePath -> IO (Maybe Text)
edit_line :: FilePath -> IO (Maybe Text)
edit_line FilePath
fname = forall a.
FilePath -> FilePath -> Text -> (FilePath -> IO a) -> IO a
with_temp FilePath
"repl-edit-history-" FilePath
"" Text
"" forall a b. (a -> b) -> a -> b
$ \FilePath
tmp -> do
    let cmdline :: [FilePath]
cmdline =
            [ FilePath
"-c", FilePath
"nmap ZZ :set write \\| .w! " forall a. Semigroup a => a -> a -> a
<> FilePath
tmp forall a. Semigroup a => a -> a -> a
<> FilePath
" \\| q!<cr>"
            , FilePath
"-c", FilePath
"set nowrite"
            , FilePath
fname
            ]
    forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (FilePath -> [FilePath] -> IO Bool
wait_for_command FilePath
"vim" [FilePath]
cmdline)
        (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
Text.strip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO Text
Text.IO.readFile FilePath
tmp)
        (forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing)

-- | This will abort the editor on a force-quit from karya.  If I leave it
-- open, it's too easy to forget, and then load another score, and it wants
-- to write to the wrong score.
--
-- TODO: I would much rather have this trigger the editor to save and quit but
-- for that I'd need a two way shutdown protocol.
wait_for_command :: FilePath -> [String] -> IO Bool
wait_for_command :: FilePath -> [FilePath] -> IO Bool
wait_for_command FilePath
cmd [FilePath]
args = do
    Text
tty_state <- Text -> Text
Text.strip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> [FilePath] -> IO Text
capture FilePath
"stty" [FilePath
"-g"]
    (Maybe Handle
_, Maybe Handle
_, Maybe Handle
_, ProcessHandle
pid) <- CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
Process.createProcess forall a b. (a -> b) -> a -> b
$
        (FilePath -> [FilePath] -> CreateProcess
Process.proc FilePath
cmd [FilePath]
args) { delegate_ctlc :: Bool
Process.delegate_ctlc = Bool
True }
    forall e a. Exception e => IO a -> IO (Either e a)
Exception.try (ProcessHandle -> IO ExitCode
Process.waitForProcess ProcessHandle
pid) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left Interrupt
Haskeline.Interrupt -> do
            ProcessHandle -> IO ()
Process.terminateProcess ProcessHandle
pid
            -- Without this the terminal wedges, probably due to both vim
            -- and haskeline wanting to mess with terminal state.
            FilePath -> [FilePath] -> IO ()
Process.callProcess FilePath
"stty" [Text -> FilePath
untxt Text
tty_state]
            ExitCode
_ <- ProcessHandle -> IO ExitCode
Process.waitForProcess ProcessHandle
pid
            FilePath -> IO ()
putStrLn FilePath
"Interrupted by karya quitting, editor killed and tty\
                \ state restored."
            FilePath -> IO ()
putStrLn FilePath
"Any unsaved edits saved as log/*.swp, vim -r log/*.swp\
                \ to recover."
            forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        Right ExitCode
Exit.ExitSuccess -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        Right (Exit.ExitFailure Int
code) -> do
            -- Maybe the binary wasn't found, but vim seems to return 1
            -- unpredictably.
            forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.warn forall a b. (a -> b) -> a -> b
$ Text
"non-zero exit code from "
                forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt (FilePath
cmd forall a. a -> [a] -> [a]
: [FilePath]
args) forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Int
code
            forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

-- This can't use readProcess, which always pipes stdin, which stty doesn't
-- likek.
capture :: String -> [String] -> IO Text
capture :: FilePath -> [FilePath] -> IO Text
capture FilePath
cmd [FilePath]
args =
    forall a.
CreateProcess
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
Process.withCreateProcess CreateProcess
proc forall a b. (a -> b) -> a -> b
$ \Maybe Handle
Nothing (Just Handle
outh) Maybe Handle
Nothing ProcessHandle
pid -> do
        Text
stdout <- Handle -> IO Text
Text.IO.hGetContents Handle
outh
        -- TODO check for error
        ProcessHandle -> IO ExitCode
Process.waitForProcess ProcessHandle
pid
        forall (m :: * -> *) a. Monad m => a -> m a
return Text
stdout
    where
    proc :: CreateProcess
proc = (FilePath -> [FilePath] -> CreateProcess
Process.proc FilePath
cmd [FilePath]
args) { std_out :: StdStream
Process.std_out = StdStream
Process.CreatePipe }