Work on terminal tab completion/scrolling

2025-12-28 18:16:24 +00:00
parent bb376b0a56
commit 4390a82d64
4 changed files with 295 additions and 214 deletions
@@ -1,4 +1,5 @@
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE TupleSections #-}

 module Dodge.Terminal (
    makeTermLine,
@@ -10,10 +11,15 @@ module Dodge.Terminal (
    makeTermPara,
    terminalReturnEffect,
    getCommands,
-    tabComplete,
+--    tabComplete,
    tlSetStatus,
    tlDoEffect,
    termTextColor,
+    doTabComplete,
+--    recComFindSuccessor,
+--    recComFindPredecessor,
+    recComFindMin,
+    recComFindMax,
 ) where

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

 textTerminal :: Terminal
 textTerminal = defaultTerminal{_tmBootLines = textInputBlurb []}
@@ -46,27 +53,26 @@ termSoundLine = TLine 0 [] . TmWdWdTermSound
 termTextColor :: Color
 termTextColor = greyN 0.9

-getCommands :: World -> Terminal -> PTE.TrieMap Char (PTE.TrieMap Char [TerminalLine])
+--type TCommands = PTE.TrieMap Char (PTE.TrieMap Char [TerminalLine])
+type TCommands = RecCommands [TerminalLine]
+
+getCommands :: World -> Terminal -> TCommands
 getCommands w tm = foldMap (getCommand w tm) $ tm ^. tmCommands

-getCommand ::
-    World ->
-    Terminal ->
-    TCom ->
-    PTE.TrieMap Char (PTE.TrieMap Char [TerminalLine])
+getCommand :: World -> Terminal -> TCom -> TCommands
 getCommand w tm = \case
-    TCInfo x z -> PTE.singleton x (PTE.singleton "" (makeTermPara z))
+    TCInfo x z -> RCommands $ PTE.singleton x (Right (makeTermPara z))
    TCBase -> quitCommand <> toggleCommands tm
    TCDamageCommand -> damageCodeCommand w tm

-damageCodeCommand :: World -> Terminal -> PTE.TrieMap Char (PTE.TrieMap Char [TerminalLine])
-damageCodeCommand w _ =
-    PTE.singleton "DAMAGECODE" $ PTE.fromList $ mapMaybe f [minBound ..]
+damageCodeCommand :: World -> Terminal -> TCommands
+damageCodeCommand w _ = RCommands .
+    PTE.singleton "DAMAGECODE" . Left . RCommands $ PTE.fromList $ mapMaybe f [minBound ..]
  where
-    f :: SensorType -> Maybe (String, [TerminalLine])
+    f :: SensorType -> Maybe (String, Either TCommands [TerminalLine])
    f st = do
        s <- g st
-        return (s, decodeSensorType st w)
+        return (s, Right $ decodeSensorType st w)
    g =
        fmap (map toUpper . reverse)
            . List.stripPrefix (reverse "Sensor")
@@ -78,15 +84,16 @@ decodeSensorType st w = fromMaybe [] $ do
    x <- w ^? cWorld . cwGen . cwgParams . sensorCoding . ix st
    return [makeTermLine $ show x]

-toggleCommands :: Terminal -> PTE.TrieMap Char (PTE.TrieMap Char [TerminalLine])
+toggleCommands :: Terminal -> TCommands
 toggleCommands tm
    | null ts = mempty
-    | otherwise = PTE.singleton "TOGGLE" $ PTE.fromList $ f <$> M.toList ts
+    | otherwise = RCommands . PTE.singleton "TOGGLE" . Left . RCommands . PTE.fromList 
+        $ f <$> M.toList ts
  where
    ts = tm ^. tmToggles
    f (s, x) =
        ( s
-        ,
+        , Right
            [ TLine
                1
                [TerminalLineConst (s ++ " TOGGLE DONE!") termTextColor]
@@ -97,8 +104,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."

-quitCommand :: PTE.TrieMap Char (PTE.TrieMap Char [TerminalLine])
-quitCommand = PTE.singleton "QUIT" (PTE.singleton "" [TLine 0 [] TmWdWdPowerDownTerminal])
+quitCommand :: TCommands
+quitCommand = RCommands . PTE.singleton "QUIT" $ Right [TLine 0 [] TmWdWdPowerDownTerminal]

 makeTermLine :: String -> TerminalLine
 makeTermLine = makeColorTermLine termTextColor
@@ -121,51 +128,118 @@ makeColorTermLine col str = TLine 1 [TerminalLineConst str col] TmWdId
 commandColor :: Color
 commandColor = yellow

-tabComplete :: World -> Terminal -> Terminal
-tabComplete w tm = fromMaybe tm $ do
+--tabComplete :: World -> Terminal -> Terminal
+--tabComplete w tm = fromMaybe tm $ do
+--    s <- tm ^? tmStatus . tiText
+--    return $ tabComplete' s w tm
+--
+---- ugly, can improve output to explain when showing available arguments
+--tabComplete' :: String -> World -> Terminal -> Terminal
+--tabComplete' s' w tm = case PTE.lookup s $ getCommands w tm of
+--    Just m -> f (s ++ " ") $ PTE.toList $ PTE.lookupPrefix a m
+--    Nothing -> f "" $ PTE.toList $ PTE.lookupPrefix s $ getCommands w tm
+--  where
+--    ss = words s'
+--    s = fromMaybe "" $ ss ^? ix 0
+--    a = fromMaybe "" $ ss ^? ix 1
+--    f y m' = case fmap fst m' of
+--        [] -> tm
+--        [x] -> tm & tmStatus . tiText .~ (y ++ x)
+--        xs ->
+--            tm
+--                & tmStatus
+--                .~ TerminalLineRead
+--                & tmFutureLines
+--                .~ ( makeColorTermPara
+--                        commandColor
+--                        (unwords xs)
+--                        <> [TLine 1 [] . TmTmSetStatus $ TerminalTextInput s']
+--                   )
+
+data TabCompletion a
+    = TabMatch a
+    | TabComplete String
+    | TabMultiComplete [String]
+    | TabFail
+
+data RecCommands a = 
+    RCommands {_rCommands :: (PTE.TrieMap Char (Either (RecCommands a) a))}
+
+-- assumes that each command Trie has at least one successful command
+recComFindMin :: RecCommands a -> Maybe ([String], a)
+recComFindMin (RCommands m) = case PTE.findMin m of
+    Just (s,Right a) -> Just ([s],a)
+    Just (s,Left m') -> recComFindMin m' & _Just . _1 .:~ s
+    Nothing -> Nothing
+
+recComFindMax :: RecCommands a -> Maybe ([String], a)
+recComFindMax (RCommands m) = case PTE.findMax m of
+    Just (s,Right a) -> Just ([s],a)
+    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)) $ 
+--
+--recComFindPredecessor :: [String] -> RecCommands a -> Maybe ([String],a)
+--recComFindPredecessor (s:ss) (RCommands m) = Nothing
+
+instance Semigroup (RecCommands a) where
+    RCommands x <> RCommands y = RCommands $ x <> y
+
+instance Monoid (RecCommands a) where
+    mempty = RCommands mempty
+    
+
+tbComplete :: String -> PTE.TrieMap Char a -> TabCompletion a
+tbComplete s t = case e of
+    [] | Just x <- mx -> TabMatch x
+    [] -> case fmap fst $ PTE.toList t' of
+        [] -> TabFail
+        ss -> TabMultiComplete ss
+    _ -> TabComplete e
+  where
+    (e, mx, t') = PTE.splitPrefix $ PTE.deletePrefix s t
+
+recTabComplete :: String -> TCommands -> TabCompletion [TerminalLine]
+recTabComplete s (RCommands t) = fromMaybe (TabMultiComplete $ allstrings $ t) $ do
+    (s1,ss) <- stripHead $ words s
+    case tbComplete s1 t of
+        TabComplete e -> return $ TabComplete e
+        TabMultiComplete es -> return $ TabMultiComplete (fmap (s1 <>) es)
+        TabFail -> return $ TabFail
+        TabMatch (Right x) -> return $ TabMatch x
+        TabMatch (Left rm) -> return $ recTabComplete (unwords ss) rm
+  where
+    stripHead (x:xs) = Just (x,xs)
+    stripHead _ = Nothing
+    allstrings = fmap fst . PTE.toList
+
+doTabComplete :: World -> Terminal -> Terminal
+doTabComplete w tm = fromMaybe tm $ do
    s <- tm ^? tmStatus . tiText
-    return $ tabComplete' s w tm
+    case recTabComplete s $ getCommands w tm of
+        TabMatch _ -> return tm
+        TabComplete e -> return $ tm & tmStatus . tiText <>~ e
+        TabMultiComplete ss -> return $ tm 
+            & tmStatus .~ TerminalLineRead
+            & tmFutureLines .~ 
+            (makeColorTermPara commandColor (unwords ss) <> [TLine 1 [] . TmTmSetStatus $ TerminalTextInput s])

-- ugly, can improve output to explain when showing available arguments
-tabComplete' :: String -> World -> Terminal -> Terminal
-tabComplete' s' w tm = case PTE.lookup s $ getCommands w tm of
-    Just m -> f (s ++ " ") $ PTE.toList $ PTE.lookupPrefix a m
-    Nothing -> f "" $ PTE.toList $ PTE.lookupPrefix s $ getCommands w tm
-  where
-    ss = words s'
-    s = fromMaybe "" $ ss ^? ix 0
-    a = fromMaybe "" $ ss ^? ix 1
-    f y m' = case fmap fst m' of
-        [] -> tm
-        [x] -> tm & tmStatus . tiText .~ (y ++ x)
-        xs ->
-            tm
-                & tmStatus
-                .~ TerminalLineRead
-                & tmFutureLines
-                .~ ( makeColorTermPara
-                        commandColor
-                        (unwords xs)
-                        <> [TLine 1 [] . TmTmSetStatus $ TerminalTextInput s']
-                   )

-tComplete 
-    :: String 
-    -> PTE.TrieMap Char (PTE.TrieMap Char [TerminalLine])
-    -> Either (String,[String]) (String,[String])
-tComplete s pt = fromMaybe (Left (mempty,allcommands pt)) $ do
-    s1 <- words s ^? ix 0
-    let (e1,mx,pt') = PTE.splitPrefix $ PTE.deletePrefix s1 pt
-    case e1 of
-        [] -> do
-            pt'' <- mx 
-            return $ fromMaybe (Right (mempty, allcommands pt'')) $ do
-                s2 <- words s ^? ix 1
-                let (e2,_,pt3) = PTE.splitPrefix $ PTE.deletePrefix s2 pt''
-                Just $ Right (e2, allcommands pt3)
-        _ -> Just $ Left (e1, allcommands pt')
-  where
-    allcommands = fmap fst . PTE.toList
+        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 =
@@ -193,33 +267,34 @@ simpleTermMessage strs = defaultTerminal & tmBootLines .~ map makeTermLine strs

 -- list available arguments on function input?
 terminalReturnEffect :: Int -> World -> World
-terminalReturnEffect tmid w = fromMaybe w $ do
-    tm' <- w ^? cWorld . lWorld . terminals . ix tmid
-    let tm = tabComplete w tm'
-    s <- tm ^? tmStatus . tiText
-    let ss = fromMaybe [makeTermLine "ERROR: INPUT NOT RECOGNISED"] $ do
-            let args = words s
-            case args of
-                [] -> return helpPara
-                (x : _) -> do
-                    teff <- PTE.lookup x (getCommands w tm)
-                    let y = fromMaybe "" (args ^? ix 1)
-                    PTE.lookup y teff
-    return $
-        w
-            & totm
-            . tmDisplayedLines
-            .:~ (getPromptTM ++ s, termTextColor)
-            & totm
-            . tmFutureLines
-            .~ ss
-            <> tlSetStatus (TerminalTextInput "")
-                & totm
-                . tmCommandHistory
-                %~ take 10
-                . (s :)
-                & totm
-                . tmStatus
-                .~ TerminalLineRead
-  where
-    totm = cWorld . lWorld . terminals . ix tmid
+terminalReturnEffect tmid w = w
+-- fromMaybe w $ do
+--    tm' <- w ^? cWorld . lWorld . terminals . ix tmid
+--    let tm = tabComplete w tm'
+--    s <- tm ^? tmStatus . tiText
+--    let ss = fromMaybe [makeTermLine "ERROR: INPUT NOT RECOGNISED"] $ do
+--            let args = words s
+--            case args of
+--                [] -> return helpPara
+--                (x : _) -> do
+--                    teff <- PTE.lookup x (getCommands w tm)
+--                    let y = fromMaybe "" (args ^? ix 1)
+--                    PTE.lookup y teff
+--    return $
+--        w
+--            & totm
+--            . tmDisplayedLines
+--            .:~ (getPromptTM ++ s, termTextColor)
+--            & totm
+--            . tmFutureLines
+--            .~ ss
+--            <> tlSetStatus (TerminalTextInput "")
+--                & totm
+--                . tmCommandHistory
+--                %~ take 10
+--                . (s :)
+--                & totm
+--                . tmStatus
+--                .~ TerminalLineRead
+--  where
+--    totm = cWorld . lWorld . terminals . ix tmid