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

{-# LANGUAGE CPP #-}
{- | Process a textual language, which may look familiar, to perform UI state
    changes.

    The incoming commands are received via Msg.Socket msgs.

    TODO currently this will reload any updated modules as interpreted.  While
    I want to do this for explicitly named modules (Cmd.Repl.Environ and
    Local/Repl/ *.hs), it's just annoying and brittle when applied to the main
    src files.  Is there a way to get ghc to load the objects even if the
    source files are newer?
-}
module Cmd.Repl (
    with_socket
    , Session, make_session, interpreter, respond
    , accept_msg
) where
import qualified Control.DeepSeq as DeepSeq
import qualified Control.Exception as Exception
import qualified Data.Text as Text
import qualified Network.Socket as Socket
import qualified System.Directory as Directory
import qualified System.IO as IO

import qualified App.Config as Config
import qualified App.Path as Path
import qualified App.ReplProtocol as ReplProtocol
import qualified Cmd.Cmd as Cmd
import qualified Cmd.Msg as Msg
import qualified Cmd.Repl.Fast as Fast
import qualified Derive.Parse as Parse
import qualified Ui.Id as Id
import qualified Ui.Ui as Ui
import qualified Util.Exceptions as Exceptions
import qualified Util.Log as Log
import qualified Util.Network as Network

import Global

#include "hsconfig.h"
#if defined(INTERPRETER_GHC)
import qualified Cmd.ReplGhc as ReplImpl
#else
import qualified Cmd.ReplStub as ReplImpl
#endif


-- | Acquire a new unix socket, and delete when done.
--
-- This tries to find an unused socket name.  It might seem like overkill, but
-- the previous strategy of unconditionally deleting and recreating the single
-- socket meant that accidentally starting the app twice in the same directory
-- would make the first one unreachable.
with_socket :: (Socket.Socket -> IO a) -> IO a
with_socket :: forall a. (Socket -> IO a) -> IO a
with_socket Socket -> IO a
app = do
    (FilePath
fname, Socket
socket) <- [FilePath] -> IO (FilePath, Socket)
try_socket forall a b. (a -> b) -> a -> b
$
        FilePath
Config.repl_socket_name
        forall a. a -> [a] -> [a]
: [FilePath
Config.repl_socket_name forall a. Semigroup a => a -> a -> a
<> FilePath
"." forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> FilePath
show Integer
n | Integer
n <- [Integer
1..Integer
4]]
    Socket -> IO a
app Socket
socket 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
fname)
    where
    -- Let the exception through on the last try.
    try_socket :: [FilePath] -> IO (FilePath, Socket)
try_socket [FilePath
fname] = (FilePath
fname,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO Socket
Network.listenUnix FilePath
fname
    try_socket (FilePath
fname : [FilePath]
fnames) =
        forall a. IO a -> IO (Maybe a)
Exceptions.ignoreIOError (FilePath -> IO Socket
Network.listenUnix FilePath
fname) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Maybe Socket
Nothing -> [FilePath] -> IO (FilePath, Socket)
try_socket [FilePath]
fnames
            Just Socket
socket -> forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath
fname, Socket
socket)
    try_socket [] = forall (m :: * -> *) a. (Stack, MonadIO m) => Text -> m a
errorIO Text
"no socket files?"

-- | This is the persistent interpreter session which is stored in the global
-- state.
type Session = ReplImpl.Session

make_session :: IO Session
make_session :: IO Session
make_session = IO Session
ReplImpl.make_session

-- | This is the interpreter thread, which should be started when the app
-- starts.  It's in a separate thread so it can run in its own monad.
interpreter :: Session -> IO ()
interpreter :: Session -> IO ()
interpreter = Session -> IO ()
ReplImpl.interpreter

respond :: Session -> Msg.Msg -> Cmd.CmdT IO Cmd.Status
respond :: Session -> Msg -> CmdT IO Status
respond Session
session Msg
msg = do
    (Handle
response_hdl, Query
query) <- case Msg
msg of
        Msg.Socket Handle
hdl Query
s -> forall (m :: * -> *) a. Monad m => a -> m a
return (Handle
hdl, Query
s)
        Msg
_ -> forall (m :: * -> *) a. M m => m a
Cmd.abort
    (Maybe Response
mb_response, Status
status) <- case Query
query of
        Query
ReplProtocol.QSaveFile -> do
            Maybe FilePath
save_file <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SaveFile -> FilePath
name_of forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. M m => (State -> a) -> m a
Cmd.gets State -> Maybe (Writable, SaveFile)
Cmd.state_save_file
            forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Maybe FilePath -> Response
ReplProtocol.RSaveFile Maybe FilePath
save_file, Status
Cmd.Done)
        ReplProtocol.QCommand Text
expr -> Session -> Text -> CmdT IO (Maybe Response, Status)
command Session
session (Text -> Text
Text.strip Text
expr)
        ReplProtocol.QCompletion Text
prefix -> do
            [Text]
words <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Session -> Text -> IO [Text]
ReplImpl.complete Session
session Text
prefix
            forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [Text] -> Response
ReplProtocol.RCompletion [Text]
words, Status
Cmd.Done)
        ReplProtocol.QNotify NotifySeq
notify -> do
            case NotifySeq
notify of
                NotifySeq
ReplProtocol.NEditorOpened -> forall (m :: * -> *). M m => (State -> State) -> m ()
Cmd.modify forall a b. (a -> b) -> a -> b
$ \State
st -> State
st
                    { state_saved :: Saved
Cmd.state_saved = (State -> Saved
Cmd.state_saved State
st)
                        { _editor_open :: Bool
Cmd._editor_open = Bool
True }
                    }
                NotifySeq
ReplProtocol.NEditorClosed -> forall (m :: * -> *). M m => (State -> State) -> m ()
Cmd.modify forall a b. (a -> b) -> a -> b
$ \State
st -> State
st
                    { state_saved :: Saved
Cmd.state_saved = (State -> Saved
Cmd.state_saved State
st)
                        { _editor_open :: Bool
Cmd._editor_open = Bool
False }
                    }
            forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Maybe a
Nothing, Status
Cmd.Done)
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => (e -> IO a) -> IO a -> IO a
Exception.handle forall {m :: * -> *}. LogMonad m => IOError -> m ()
warn_io_errors forall a b. (a -> b) -> a -> b
$ do
        forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe Response
mb_response forall a b. (a -> b) -> a -> b
$ Handle -> Response -> IO ()
ReplProtocol.seq_send Handle
response_hdl
        Handle -> IO ()
IO.hClose Handle
response_hdl
    forall (m :: * -> *) a. Monad m => a -> m a
return Status
status
    where
    name_of :: SaveFile -> FilePath
name_of (Cmd.SaveState Canonical
fname) = Canonical -> FilePath
Path.to_path Canonical
fname
    name_of (Cmd.SaveRepo Canonical
fname) = Canonical -> FilePath
Path.to_path Canonical
fname
    warn_io_errors :: IOError -> m ()
warn_io_errors (IOError
exc :: IOError) =
        forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.warn forall a b. (a -> b) -> a -> b
$ Text
"caught exception from socket write: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt IOError
exc

command :: ReplImpl.Session -> Text
    -> Cmd.CmdT IO (Maybe ReplProtocol.Response, Cmd.Status)
command :: Session -> Text -> CmdT IO (Maybe Response, Status)
command Session
session Text
expr = do
    Namespace
ns <- forall (m :: * -> *). M m => m Namespace
Ui.get_namespace
    Text
expr <- forall (m :: * -> *) err a.
(Stack, M m) =>
(err -> Text) -> Either err a -> m a
Cmd.require_right (Text
"expand_macros: "<>) forall a b. (a -> b) -> a -> b
$ Namespace -> Text -> Either Text Text
expand_macros Namespace
ns Text
expr
    forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.debug forall a b. (a -> b) -> a -> b
$ Text
"repl input: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Text
expr
    CmdT IO CmdResult
cmd <- case FilePath -> Maybe (CmdT IO CmdResult)
Fast.fast_interpret (Text -> FilePath
untxt Text
expr) of
        Just CmdT IO CmdResult
cmd -> forall (m :: * -> *) a. Monad m => a -> m a
return CmdT IO CmdResult
cmd
        Maybe (CmdT IO CmdResult)
Nothing -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Session -> Text -> IO (CmdT IO CmdResult)
ReplImpl.interpret Session
session Text
expr
    (CmdResult
response, Status
status) <- CmdT IO CmdResult -> CmdT IO (CmdResult, Status)
run_cmdio forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. M m => Text -> m a -> m a
Cmd.name (Text
"repl: " forall a. Semigroup a => a -> a -> a
<> Text
expr) CmdT IO CmdResult
cmd
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ CmdResult -> Response
ReplProtocol.RCommand CmdResult
response, Status
status)

-- | Replace \@some-id with @(make_id ns \"some-id\")@
expand_macros :: Id.Namespace -> Text -> Either Text Text
expand_macros :: Namespace -> Text -> Either Text Text
expand_macros Namespace
namespace Text
expr = (Text -> Text) -> Text -> Either Text Text
Parse.expand_macros forall a. Show a => a -> Text
replace Text
expr
    where
    replace :: a -> Text
replace a
ident = Text
"(make_id " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt (Namespace -> Text
Id.un_namespace Namespace
namespace) forall a. Semigroup a => a -> a -> a
<> Text
" "
        forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt a
ident forall a. Semigroup a => a -> a -> a
<> Text
")"

-- | Run the Cmd under an IO exception handler.
run_cmdio :: Cmd.CmdT IO ReplProtocol.CmdResult
    -> Cmd.CmdT IO (ReplProtocol.CmdResult, Cmd.Status)
run_cmdio :: CmdT IO CmdResult -> CmdT IO (CmdResult, Status)
run_cmdio CmdT IO CmdResult
cmd = do
    State
ui_state <- forall (m :: * -> *). M m => m State
Ui.get
    State
cmd_state <- forall (m :: * -> *). M m => m State
Cmd.get
    Either
  SomeException
  (State, [Thru], Either Error (CmdResult, State, UiDamage), [Msg])
run_result <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => IO a -> IO (Either e a)
Exception.try forall a b. (a -> b) -> a -> b
$ do
        (State
cmd_state, [Thru]
midi, [Msg]
logs, Either Error (CmdResult, State, UiDamage)
cmd_result) <-
            forall (m :: * -> *) a. Monad m => a -> RunCmd m m a
Cmd.run (Text -> CmdResult
ReplProtocol.raw Text
"<aborted>") State
ui_state
                (State
cmd_state { state_repl_status :: Status
Cmd.state_repl_status = Status
Cmd.Done }) CmdT IO CmdResult
cmd
        case Either Error (CmdResult, State, UiDamage)
cmd_result of
            Left Error
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
            -- Try to force out any async exceptions.  UI state may also have
            -- some, but I try to force those out in Ui.State functions.
            -- Otherwise, if an error gets out of this try block it can kill
            -- the responder when serializes the value for the socket.
            Right (CmdResult
val, State
_state, UiDamage
_updates) -> CmdResult
val forall a b. NFData a => a -> b -> b
`DeepSeq.deepseq` forall (m :: * -> *) a. Monad m => a -> m a
return ()
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *). LogMonad m => Msg -> m ()
Log.write [Msg]
logs
        forall (m :: * -> *) a. Monad m => a -> m a
return (State
cmd_state, [Thru]
midi, Either Error (CmdResult, State, UiDamage)
cmd_result, [Msg]
logs)
    case Either
  SomeException
  (State, [Thru], Either Error (CmdResult, State, UiDamage), [Msg])
run_result of
        Left (SomeException
exc :: Exception.SomeException) -> forall (m :: * -> *) a. Monad m => a -> m a
return
            (Text -> CmdResult
ReplProtocol.raw forall a b. (a -> b) -> a -> b
$ Text
"IO exception: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt SomeException
exc, Status
Cmd.Done)
        Right (State
cmd_state, [Thru]
thru, Either Error (CmdResult, State, UiDamage)
cmd_result, [Msg]
logs) -> case Either Error (CmdResult, State, UiDamage)
cmd_result of
            Left Error
err -> forall (m :: * -> *) a. Monad m => a -> m a
return
                (Text -> CmdResult
ReplProtocol.raw forall a b. (a -> b) -> a -> b
$ Text
"State error: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Error
err, Status
Cmd.Done)
            Right (ReplProtocol.CmdResult Result
response [Msg]
eval_logs, State
ui_state,
                    UiDamage
damage) -> do
                forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *). M m => Thru -> m ()
Cmd.write_thru [Thru]
thru
                forall (m :: * -> *). M m => State -> m ()
Cmd.put forall a b. (a -> b) -> a -> b
$ State
cmd_state { state_repl_status :: Status
Cmd.state_repl_status = Status
Cmd.Continue }
                -- Should be safe, because I'm writing the damage.
                forall (m :: * -> *). M m => State -> m ()
Ui.unsafe_put State
ui_state
                forall (m :: * -> *). M m => UiDamage -> m ()
Ui.damage UiDamage
damage
                forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *). LogMonad m => Msg -> m ()
Log.write [Msg]
eval_logs
                forall (m :: * -> *) a. Monad m => a -> m a
return
                    ( Result -> [Msg] -> CmdResult
ReplProtocol.CmdResult Result
response ([Msg]
eval_logs forall a. [a] -> [a] -> [a]
++ [Msg]
logs)
                    , State -> Status
Cmd.state_repl_status State
cmd_state
                    )

-- | Block and read a single message from the REPL client, and return it
-- along with a response handle.  The Query should eventually make it's way to
-- 'respond'.
accept_msg :: Socket.Socket -> IO (Maybe (IO.Handle, ReplProtocol.Query))
accept_msg :: Socket -> IO (Maybe (Handle, Query))
accept_msg Socket
socket = forall e a. Exception e => (e -> IO a) -> IO a -> IO a
Exception.handle forall {m :: * -> *} {a}. LogMonad m => IOError -> m (Maybe a)
handle forall a b. (a -> b) -> a -> b
$ do
    (Socket
socket, SockAddr
_peer) <- Socket -> IO (Socket, SockAddr)
Socket.accept Socket
socket
    Handle
hdl <- Socket -> IOMode -> IO Handle
Socket.socketToHandle Socket
socket IOMode
IO.ReadWriteMode
    Query
msg <- Handle -> IO Query
ReplProtocol.seq_receive Handle
hdl
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (Handle
hdl, Query
msg)
    where
    handle :: IOError -> m (Maybe a)
handle (IOError
exc :: IOError) = do
        forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.warn forall a b. (a -> b) -> a -> b
$ Text
"caught exception from socket read: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt IOError
exc
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing