summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--main/Main.hs86
1 files changed, 55 insertions, 31 deletions
diff --git a/main/Main.hs b/main/Main.hs
index ca980ca..a226c6b 100644
--- a/main/Main.hs
+++ b/main/Main.hs
@@ -214,12 +214,54 @@ interactiveLoop st opts = runInputT inputSettings $ do
erebosHead <- liftIO $ loadLocalStateHead st
outputStrLn $ T.unpack $ displayIdentity $ headLocalIdentity erebosHead
- haveTerminalUI >>= \case True -> return ()
- False -> error "Requires terminal"
+ tui <- haveTerminalUI
extPrint <- getExternalPrint
let extPrintLn str = extPrint $ case reverse str of ('\n':_) -> str
_ -> str ++ "\n";
+ let getInputLinesTui eprompt = do
+ prompt <- case eprompt of
+ Left cstate -> do
+ pname <- case csContext cstate of
+ NoContext -> return ""
+ SelectedPeer peer -> peerIdentity peer >>= return . \case
+ PeerIdentityFull pid -> maybe "<unnamed>" T.unpack $ idName $ finalOwner pid
+ PeerIdentityRef wref _ -> "<" ++ BC.unpack (showRefDigest $ wrDigest wref) ++ ">"
+ PeerIdentityUnknown _ -> "<unknown>"
+ SelectedContact contact -> return $ T.unpack $ contactName contact
+ SelectedConversation conv -> return $ T.unpack $ conversationName conv
+ return $ pname ++ "> "
+ Right prompt -> return prompt
+ Just input <- lift $ getInputLine prompt
+ case reverse input of
+ _ | all isSpace input -> getInputLinesTui eprompt
+ '\\':rest -> (reverse ('\n':rest) ++) <$> getInputLinesTui (Right ">> ")
+ _ -> return input
+
+ getInputCommandTui cstate = do
+ input <- getInputLinesTui cstate
+ let (CommandM cmd, line) = case input of
+ '/':rest -> let (scmd, args) = dropWhile isSpace <$> span (\c -> isAlphaNum c || c == '-') rest
+ in if not (null scmd) && all isDigit scmd
+ then (cmdSelectContext, scmd)
+ else (fromMaybe (cmdUnknown scmd) $ lookup scmd commands, args)
+ _ -> (cmdSend, input)
+ return (cmd, line)
+
+ getInputLinesPipe = do
+ lift (getInputLine "") >>= \case
+ Just input -> return input
+ Nothing -> liftIO $ forever $ threadDelay 100000000
+
+ getInputCommandPipe _ = do
+ input <- getInputLinesPipe
+ let (scmd, args) = dropWhile isSpace <$> span (\c -> isAlphaNum c || c == '-') input
+ let (CommandM cmd, line) = (fromMaybe (cmdUnknown scmd) $ lookup scmd commands, args)
+ return (cmd, line)
+
+ let getInputCommand = if tui then getInputCommandTui . Left
+ else getInputCommandPipe
+
_ <- liftIO $ do
tzone <- getCurrentTimeZone
watchReceivedMessages erebosHead $
@@ -250,36 +292,15 @@ interactiveLoop st opts = runInputT inputSettings $ do
(op, updateType) <- modifyMVar peers (return . update)
let updateType' = if dropped then "DEL" else updateType
idx <- modifyMVar contextOptions (return . ctxUpdate (1 :: Int))
- when (Just shown /= op) $ extPrint $ "[" <> show idx <> "] PEER " <> updateType' <> " " <> shown
+ when (Just shown /= op) $ extPrintLn $ "[" <> show idx <> "] PEER " <> updateType' <> " " <> shown
_ -> return ()
- let getInputLines prompt = do
- Just input <- lift $ getInputLine prompt
- case reverse input of
- _ | all isSpace input -> getInputLines prompt
- '\\':rest -> (reverse ('\n':rest) ++) <$> getInputLines ">> "
- _ -> return input
-
let process :: CommandState -> MaybeT (InputT IO) CommandState
process cstate = do
- pname <- case csContext cstate of
- NoContext -> return ""
- SelectedPeer peer -> peerIdentity peer >>= return . \case
- PeerIdentityFull pid -> maybe "<unnamed>" T.unpack $ idName $ finalOwner pid
- PeerIdentityRef wref _ -> "<" ++ BC.unpack (showRefDigest $ wrDigest wref) ++ ">"
- PeerIdentityUnknown _ -> "<unknown>"
- SelectedContact contact -> return $ T.unpack $ contactName contact
- SelectedConversation conv -> return $ T.unpack $ conversationName conv
- input <- getInputLines $ pname ++ "> "
- let (CommandM cmd, line) = case input of
- '/':rest -> let (scmd, args) = dropWhile isSpace <$> span (\c -> isAlphaNum c || c == '-') rest
- in if not (null scmd) && all isDigit scmd
- then (cmdSelectContext $ read scmd, args)
- else (fromMaybe (cmdUnknown scmd) $ lookup scmd commands, args)
- _ -> (cmdSend, input)
+ (cmd, line) <- getInputCommand cstate
h <- liftIO (reloadHead $ csHead cstate) >>= \case
Just h -> return h
- Nothing -> do lift $ lift $ extPrint "current head deleted"
+ Nothing -> do lift $ lift $ extPrintLn "current head deleted"
mzero
res <- liftIO $ runExceptT $ flip execStateT cstate { csHead = h } $ runReaderT cmd CommandInput
{ ciServer = server
@@ -296,7 +317,7 @@ interactiveLoop st opts = runInputT inputSettings $ do
| csQuit cstate' -> mzero
| otherwise -> return cstate'
Left err -> do
- lift $ lift $ extPrint $ "Error: " ++ err
+ lift $ lift $ extPrintLn $ "Error: " ++ err
return cstate
let loop (Just cstate) = runMaybeT (process cstate) >>= loop
@@ -404,6 +425,7 @@ commands =
, ("ice-connect", cmdIceConnect)
, ("ice-send", cmdIceSend)
#endif
+ , ("select", cmdSelectContext)
, ("quit", cmdQuit)
]
@@ -449,10 +471,12 @@ showPeer pidentity paddr =
PeerIdentityFull pid -> T.unpack $ displayIdentity pid
in name ++ " [" ++ show paddr ++ "]"
-cmdSelectContext :: Int -> Command
-cmdSelectContext n = join (asks ciContextOptions) >>= \ctxs -> if
- | n > 0, (ctx : _) <- drop (n - 1) ctxs -> modify $ \s -> s { csContext = ctx }
- | otherwise -> throwError "invalid index"
+cmdSelectContext :: Command
+cmdSelectContext = do
+ n <- read <$> asks ciLine
+ join (asks ciContextOptions) >>= \ctxs -> if
+ | n > 0, (ctx : _) <- drop (n - 1) ctxs -> modify $ \s -> s { csContext = ctx }
+ | otherwise -> throwError "invalid index"
cmdSend :: Command
cmdSend = void $ do