Fix terminal scrolling

2025-12-30 19:28:05 +00:00
parent 4390a82d64
commit 26b4b77ff6
3 changed files with 70 additions and 36 deletions
@@ -16,10 +16,11 @@ module Dodge.Terminal (
    tlDoEffect,
    termTextColor,
    doTabComplete,
--    recComFindSuccessor,
--    recComFindPredecessor,
+    recComFindSuccessor,
+    recComFindPredecessor,
    recComFindMin,
    recComFindMax,
+    recComLookup,
 ) where

 import Color
@@ -36,7 +37,6 @@ import Dodge.Terminal.Type
 import Justify
 import LensHelp
 import Sound.Data
-import Control.Applicative

 textTerminal :: Terminal
 textTerminal = defaultTerminal{_tmBootLines = textInputBlurb []}
@@ -101,8 +101,8 @@ toggleCommands tm
            ]
        )

-helpPara :: [TerminalLine]
-helpPara = makeTermPara "THIS TERMINAL PROCESSES KEYBOARD INPUT. USE [RETURN] OR [LMB] TO REGISTER YOUR INPUT. AVAILABLE COMMANDS CAN BE SCROLLED THROUGH, HOLD [RMB] TO SCROLL THROUGH ARGUMENTS. USE [TAB] FOR AUTOCOMPLETE."
+--helpPara :: [TerminalLine]
+--helpPara = makeTermPara "THIS TERMINAL PROCESSES KEYBOARD INPUT. USE [RETURN] OR [LMB] TO REGISTER YOUR INPUT. AVAILABLE COMMANDS CAN BE SCROLLED THROUGH, HOLD [RMB] TO SCROLL THROUGH ARGUMENTS. USE [TAB] FOR AUTOCOMPLETE."

 quitCommand :: TCommands
 quitCommand = RCommands . PTE.singleton "QUIT" $ Right [TLine 0 [] TmWdWdPowerDownTerminal]
@@ -178,16 +178,35 @@ recComFindMax (RCommands m) = case PTE.findMax m of
    Just (s,Left m') -> recComFindMax m' & _Just . _1 .:~ s
    Nothing -> Nothing

--recComFindSuccessor :: [String] -> RecCommands a -> Maybe ([String],a)
--recComFindSuccessor (s:[]) (RCommands m) = case PTE.lookup s m of
--    Just (Left rm) ->
--    _ -> do
--        (s',_) <- PTE.findSuccessor s m & _Just . _1 %~ return
--recComFindSuccessor (s:ss) (RCommands m) 
--    = do
--        Left rm <- PTE.lookup s m
--        recComFindSuccessor ss rm -- & _Just . _1 .:~ s
----    fromMaybe (recComFindSuccessor (s:[]) (RCommands m)) $ 
+recComLookup :: [String] -> RecCommands a -> Maybe a
+recComLookup (s:ss) (RCommands t) = do
+    x <- PTE.lookup s t
+    case x of
+        Left m -> recComLookup ss m
+        Right y -> return y
+recComLookup [] _ = Nothing
+
+-- assumes that the commands are well-formed, i.e. every tree does end in a
+-- command
+recComFindSuccessor :: [String] -> RecCommands a -> Maybe ([String],a)
+recComFindSuccessor (s:ss) (RCommands m)
+    | Just (Left rm) <- PTE.lookup s m
+    , Just (ss', x) <- recComFindSuccessor ss rm = Just (s:ss',x)
+    | otherwise = case PTE.findSuccessor s m of
+            Just (s',Right x) -> Just ([s'],x)
+            Just (s',Left rm') -> recComFindMin rm' & _Just . _1 .:~ s'
+            Nothing -> Nothing
+recComFindSuccessor [] rm = recComFindMin rm
+
+recComFindPredecessor :: [String] -> RecCommands a -> Maybe ([String],a)
+recComFindPredecessor (s:ss) (RCommands m)
+    | Just (Left rm) <- PTE.lookup s m
+    , Just (ss', x) <- recComFindPredecessor ss rm = Just (s:ss',x)
+    | otherwise = case PTE.findPredecessor s m of
+            Just (s',Right x) -> Just ([s'],x)
+            Just (s',Left rm') -> recComFindMax rm' & _Just . _1 .:~ s'
+            Nothing -> Nothing
+recComFindPredecessor [] _ = Nothing
 --
 --recComFindPredecessor :: [String] -> RecCommands a -> Maybe ([String],a)
 --recComFindPredecessor (s:ss) (RCommands m) = Nothing
@@ -232,14 +251,9 @@ doTabComplete w tm = fromMaybe tm $ do
        TabMultiComplete ss -> return $ tm 
            & tmStatus .~ TerminalLineRead
            & tmFutureLines .~ 
+            [TLine 0 [TerminalLineConst (getPromptTM <> s) termTextColor] TmWdId] <>
            (makeColorTermPara commandColor (unwords ss) <> [TLine 1 [] . TmTmSetStatus $ TerminalTextInput s])
-
-
        TabFail -> return tm
--        (e,Right x) -> return $ tm & tmStatus . tiText .~ e
--        (e,Left ss) -> return $ tm 
--            & tmStatus .~ TerminalLineRead
--            & tmFutureLines .~ (makeColorTermPara commandColor (unwords ss) <> [TLine 1 [] . TmTmSetStatus $ TerminalTextInput e])

 -- damageCodeCommand :: TerminalCommand
 -- damageCodeCommand =
@@ -267,7 +281,25 @@ simpleTermMessage strs = defaultTerminal & tmBootLines .~ map makeTermLine strs

 -- list available arguments on function input?
 terminalReturnEffect :: Int -> World -> World
-terminalReturnEffect tmid w = w
+terminalReturnEffect tmid w = w 
+    & cWorld . lWorld . terminals . ix tmid %~ terminalReturnLocal w
+
+terminalReturnLocal :: World -> Terminal -> Terminal
+terminalReturnLocal w tm = fromMaybe tm $ do
+    s <- tm ^? tmStatus . tiText
+    return $ tm 
+        & tmFutureLines .~ [TLine 0 [TerminalLineConst (getPromptTM <> s) termTextColor] TmWdId]
+        & case recTabComplete s $ getCommands w tm of
+            TabMatch x -> (tmStatus .~ TerminalLineRead )
+                . (tmFutureLines <>~ (x<>tlSetStatus (TerminalTextInput "")))
+            TabComplete e -> tmStatus . tiText <>~ e
+            TabMultiComplete ss ->
+                (tmStatus .~ TerminalLineRead)
+                . ( tmFutureLines <>~ 
+                (makeColorTermPara commandColor (unwords ss) <> [TLine 1 [] . TmTmSetStatus $ TerminalTextInput s])
+                )
+            TabFail -> id
+
 -- fromMaybe w $ do
 --    tm' <- w ^? cWorld . lWorld . terminals . ix tmid
 --    let tm = tabComplete w tm'
@@ -131,19 +131,20 @@ terminalWheelEvent yi tmid w
 --    | w & has (input . mouseButtons . ix ButtonRight)
 --      , Just TerminalTextInput{} <- w ^? cWorld . lWorld . terminals . ix tmid . tmStatus =
 --        w & cWorld . lWorld . terminals . ix tmid %~ f
--    | Just TerminalTextInput{} <- w ^? cWorld . lWorld . terminals . ix tmid . tmStatus =
--        w & cWorld . lWorld . terminals . ix tmid %~ f
+    | Just TerminalTextInput{} <- w ^? cWorld . lWorld . terminals . ix tmid . tmStatus =
+        w & cWorld . lWorld . terminals . ix tmid %~ f
    | otherwise = w
  where
--    dowrap = if yi > 0 then wrapup else wrapdown
--    wrapup s coms = recComFindSuccessor (words s) coms <|> recComFindMin coms
--    wrapdown s coms = recComFindPredecessor (words s) coms <|> recComFindMax coms
--    f tm = fromMaybe tm $ do
--        let coms = getCommands w tm
--        x <- tm ^? tmStatus . tiText
--        let s = fromMaybe "" $ x ^? to words . ix 0
--        (s', _) <- dowrap s coms
--        return $ tm & tmStatus . tiText .~ unwords s'
+    dowrap = if yi > 0 then wrapup else wrapdown
+    wrapup s coms = recComFindSuccessor (words s) coms -- <|> recComFindMin coms
+    wrapdown s coms = recComFindPredecessor (words s) coms -- <|> recComFindMax coms
+    f tm = fromMaybe tm $ do
+        let coms = getCommands w tm
+        x <- tm ^? tmStatus . tiText
+        let s = fromMaybe "" $ x ^? to words . ix 0
+        --(s', _) <- dowrap s coms
+        (s', _) <- dowrap x coms
+        return $ tm & tmStatus . tiText .~ unwords s'
 ----    g tm = fromMaybe tm $ do
 ----        let coms = getCommands w tm
 ----        x <- tm ^? tmStatus . tiText