Fix terminal scrolling

src/Dodge/Terminal.hs

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