diff options
Diffstat (limited to 'main')
| -rw-r--r-- | main/Main.hs | 42 | ||||
| -rw-r--r-- | main/State.hs | 37 | ||||
| -rw-r--r-- | main/Terminal.hs | 53 |
3 files changed, 74 insertions, 58 deletions
diff --git a/main/Main.hs b/main/Main.hs index 31523ca..a3b74b1 100644 --- a/main/Main.hs +++ b/main/Main.hs @@ -359,31 +359,27 @@ interactiveLoop st opts = withTerminal commandCompletion $ \term -> do _ | all isSpace input -> getInputLinesTui eprompt '\\':rest -> (reverse ('\n':rest) ++) <$> getInputLinesTui (Right ">> ") _ -> return input - Nothing -> KeepPrompt mzero + Nothing + | tui -> KeepPrompt mzero + | otherwise -> KeepPrompt $ liftIO $ forever $ threadDelay 100000000 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 - join $ lift $ getInputLine term $ KeepPrompt . \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 + let parseCommand cmdline = + case dropWhile isSpace <$> span (\c -> isAlphaNum c || c == '-') cmdline of + ( scmd, args ) + | not (null scmd) && all isDigit scmd + -> ( cmdSelectContext, scmd ) + + | otherwise + -> ( fromMaybe (cmdUnknown scmd) $ lookup scmd commands, args ) + + ( CommandM cmd, line ) <- getInputLinesTui cstate >>= return . \case + '/' : input -> parseCommand input + input | not tui -> parseCommand input + input -> ( cmdSend, input ) + return ( cmd, line ) + + let getInputCommand = getInputCommandTui . Left contextVar <- liftIO $ newMVar NoContext diff --git a/main/State.hs b/main/State.hs index f7bc367..b8ae418 100644 --- a/main/State.hs +++ b/main/State.hs @@ -10,7 +10,6 @@ import Control.Monad.Except import Control.Monad.IO.Class import Data.Foldable -import Data.Maybe import Data.Proxy import Data.Text (Text) import Data.Text qualified as T @@ -35,21 +34,24 @@ loadLocalStateHead term st = loadHeads st >>= \case setPrompt term "Device: " devName <- getInputLine term $ KeepPrompt . maybe T.empty T.pack - owner <- if - | T.null name -> return Nothing - | otherwise -> Just <$> createIdentity st (Just name) Nothing + ( owner, shared ) <- if + | T.null name -> do + return ( Nothing, [] ) + | otherwise -> do + owner <- createIdentity st (Just name) Nothing + shared <- wrappedStore st $ SharedState + { ssPrev = [] + , ssType = Just $ sharedTypeID @(Maybe ComposedIdentity) Proxy + , ssValue = [ storedRef $ idExtData owner ] + } + return ( Just owner, [ shared ] ) identity <- createIdentity st (if T.null devName then Nothing else Just devName) owner - shared <- wrappedStore st $ SharedState - { ssPrev = [] - , ssType = Just $ sharedTypeID @(Maybe ComposedIdentity) Proxy - , ssValue = [ storedRef $ idExtData $ fromMaybe identity owner ] - } storeHead st $ LocalState { lsPrev = Nothing , lsIdentity = idExtData identity - , lsShared = [ shared ] + , lsShared = shared , lsOther = [] } @@ -58,15 +60,18 @@ createLocalStateHead _ [] = fail "createLocalStateHead: empty name list" createLocalStateHead st ( ownerName : names ) = liftIO $ do owner <- createIdentity st ownerName Nothing identity <- foldM createSingleIdentity owner names - shared <- wrappedStore st $ SharedState - { ssPrev = [] - , ssType = Just $ sharedTypeID @(Maybe ComposedIdentity) Proxy - , ssValue = [ storedRef $ idExtData owner ] - } + shared <- case names of + [] -> return [] + _ : _ -> do + fmap (: []) $ wrappedStore st $ SharedState + { ssPrev = [] + , ssType = Just $ sharedTypeID @(Maybe ComposedIdentity) Proxy + , ssValue = [ storedRef $ idExtData owner ] + } storeHead st $ LocalState { lsPrev = Nothing , lsIdentity = idExtData identity - , lsShared = [ shared ] + , lsShared = shared , lsOther = [] } where diff --git a/main/Terminal.hs b/main/Terminal.hs index b9dca51..b8b953f 100644 --- a/main/Terminal.hs +++ b/main/Terminal.hs @@ -149,13 +149,14 @@ getInput = do getInputLine :: Terminal -> (Maybe String -> InputHandling a) -> IO a getInputLine term@Terminal {..} handleResult = do - withMVar termLock $ \_ -> do - prompt <- atomically $ do - writeTVar termShowPrompt True - readTVar termPrompt - putStr $ prompt <> "\ESC[K" - drawBottomLines term - hFlush stdout + when termAnsi $ do + withMVar termLock $ \_ -> do + prompt <- atomically $ do + writeTVar termShowPrompt True + readTVar termPrompt + putStr $ prompt <> "\ESC[K" + drawBottomLines term + hFlush stdout mbLine <- go forM_ mbLine $ \line -> do @@ -169,10 +170,12 @@ getInputLine term@Terminal {..} handleResult = do case handleResult mbLine of KeepPrompt x -> do - termPutStr term "\n\ESC[J" + when termAnsi $ do + termPutStr term "\n\ESC[J" return x ErasePrompt x -> do - termPutStr term "\r\ESC[J" + when termAnsi $ do + termPutStr term "\r\ESC[J" return x where go = getInput >>= \case @@ -180,11 +183,12 @@ getInputLine term@Terminal {..} handleResult = do atomically $ do ( pre, post ) <- readTVar termInput writeTVar termInput ( "", "" ) - writeTVar termShowPrompt False - writeTVar termBottomLines [] + when termAnsi $ do + writeTVar termShowPrompt False + writeTVar termBottomLines [] return $ Just $ pre ++ post - InputChar '\t' -> do + InputChar '\t' | termAnsi -> do options <- withMVar termLock $ const $ do ( pre, post ) <- atomically $ readTVar termInput let updatePrompt pre' = do @@ -298,7 +302,7 @@ getInputLine term@Terminal {..} handleResult = do withInput f = do withMVar termLock $ const $ do str <- atomically $ f =<< readTVar termInput - when (not $ null str) $ do + when (termAnsi && not (null str)) $ do putStr str hFlush stdout go @@ -311,6 +315,8 @@ getCurrentPromptLine Terminal {..} = do return $ prompt <> pre <> "\ESC[s" <> post <> "\ESC[u" setPrompt :: Terminal -> String -> IO () +setPrompt Terminal { termAnsi = False } _ = do + return () setPrompt term@Terminal {..} prompt = do withMVar termLock $ \_ -> do join $ atomically $ do @@ -328,17 +334,24 @@ printLine tlTerminal@Terminal {..} str = do withMVar termLock $ \_ -> do let strLines = lines str tlLineCount = length strLines - promptLine <- atomically $ do - readTVar termShowPrompt >>= \case - True -> getCurrentPromptLine tlTerminal - False -> return "" - putStr $ "\r\ESC[K" <> unlines strLines <> "\ESC[K" <> promptLine - drawBottomLines tlTerminal + if termAnsi + then do + promptLine <- atomically $ do + readTVar termShowPrompt >>= \case + True -> getCurrentPromptLine tlTerminal + False -> return "" + putStr $ "\r\ESC[K" <> unlines strLines <> "\ESC[K" <> promptLine + drawBottomLines tlTerminal + else do + putStr $ unlines strLines + hFlush stdout return TerminalLine {..} printBottomLines :: Terminal -> String -> IO () +printBottomLines Terminal { termAnsi = False } _ = do + return () printBottomLines term@Terminal {..} str = do case lines str of [] -> clearBottomLines term @@ -349,6 +362,8 @@ printBottomLines term@Terminal {..} str = do hFlush stdout clearBottomLines :: Terminal -> IO () +clearBottomLines Terminal { termAnsi = False } = do + return () clearBottomLines Terminal {..} = do withMVar termLock $ \_ -> do atomically (readTVar termBottomLines) >>= \case |