Move towards implementing terminal autocomplete
This commit is contained in:
+157
-132
@@ -1,10 +1,11 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
module Dodge.Terminal (
|
||||
doTerminalCommandEffect,
|
||||
-- doTerminalCommandEffect,
|
||||
makeTermLine,
|
||||
commandFutureLines,
|
||||
quitCommand,
|
||||
helpCommand,
|
||||
commandsCommand,
|
||||
-- commandFutureLines,
|
||||
-- quitCommand,
|
||||
-- helpCommand,
|
||||
-- commandsCommand,
|
||||
connectionBlurbLines,
|
||||
disconnectTerminal,
|
||||
basicTerminal,
|
||||
@@ -15,15 +16,18 @@ module Dodge.Terminal (
|
||||
makeTermPara,
|
||||
toggleCommand,
|
||||
terminalReturnEffect,
|
||||
getCommands,
|
||||
makeColorTermPara,
|
||||
commandColor,
|
||||
) where
|
||||
|
||||
import Dodge.Data.WorldEffect
|
||||
import qualified Data.ListTrie.Patricia.Map.Enum as PTE
|
||||
--import Dodge.Data.WorldEffect
|
||||
import Dodge.Data.Terminal.Status
|
||||
import Color
|
||||
--import Control.Monad
|
||||
import Data.Char
|
||||
import Data.Foldable
|
||||
import qualified Data.Map.Strict as M
|
||||
--import Data.Char
|
||||
--import qualified Data.Map.Strict as M
|
||||
import Data.Maybe
|
||||
import Dodge.Data.World
|
||||
import Dodge.Default
|
||||
@@ -31,18 +35,13 @@ import Dodge.SoundLogic
|
||||
import Dodge.Terminal.Type
|
||||
import Justify
|
||||
import LensHelp
|
||||
import ListHelp (safeHead, safeUncons)
|
||||
--import ListHelp (safeHead, safeUncons)
|
||||
import Sound.Data
|
||||
|
||||
basicTerminal :: Terminal
|
||||
basicTerminal =
|
||||
defaultTerminal
|
||||
{ _tmDisplayedLines = []
|
||||
, _tmFutureLines = []
|
||||
-- , _tmTitle = "TERMINAL"
|
||||
, _tmCommands = [helpCommand,commandsCommand,quitCommand]
|
||||
-- , _tmWriteCommands = [helpCommand, commandsCommand]
|
||||
, _tmBootLines = connectionBlurb
|
||||
{ _tmBootLines = connectionBlurb
|
||||
, _tmDeathEffect = TmWdWdDoDeathTriggers
|
||||
}
|
||||
|
||||
@@ -52,53 +51,53 @@ connectionBlurbLines tls =
|
||||
, TLine 0 [TerminalLineConst "LOADING TEXT INTERFACE..." termTextColor] TmWdId
|
||||
]
|
||||
++ tls
|
||||
++ [ TLine 10 [TerminalLineConst "READY FOR INPUT" termTextColor] (TmTmSetStatus (TerminalTextInput "" 0))]
|
||||
++ [ TLine 10 [TerminalLineConst "READY FOR INPUT" termTextColor] (TmTmSetStatus (TerminalTextInput ""))]
|
||||
-- ++ [TerminalLineEffect 0 (TmTmSetStatus (TerminalTextInput "" 0))]
|
||||
|
||||
quitCommand :: TerminalCommand
|
||||
quitCommand =
|
||||
TerminalCommand
|
||||
{ _tcString = "QUIT"
|
||||
, _tcAlias = ["Q", "EXIT", "X", "SHUTDOWN", ""]
|
||||
, _tcHelp = "Disconnects the terminal."
|
||||
, _tcEffect = TerminalCommandArguments $ NoArguments [TLine 0 [] TmWdWdDisconnectTerminal]
|
||||
}
|
||||
--quitCommand :: TerminalCommand
|
||||
--quitCommand =
|
||||
-- TerminalCommand
|
||||
-- { _tcString = "QUIT"
|
||||
-- , _tcAlias = ["Q", "EXIT", "X", "SHUTDOWN", ""]
|
||||
-- , _tcHelp = "Disconnects the terminal."
|
||||
-- , _tcEffect = TerminalCommandArguments $ NoArguments [TLine 0 [] TmWdWdDisconnectTerminal]
|
||||
-- }
|
||||
|
||||
helpCommand :: TerminalCommand
|
||||
helpCommand =
|
||||
TerminalCommand
|
||||
{ _tcString = "HELP"
|
||||
, _tcAlias = ["H", "MAN"]
|
||||
, _tcHelp = "Displays help for a specific command."
|
||||
, _tcEffect = TerminalCommandEffectHelp -- \tm -> OneArgument "AN AVAILABLE COMMAND" . getCommandsHelp tm
|
||||
}
|
||||
--helpCommand :: TerminalCommand
|
||||
--helpCommand =
|
||||
-- TerminalCommand
|
||||
-- { _tcString = "HELP"
|
||||
-- , _tcAlias = ["H", "MAN"]
|
||||
-- , _tcHelp = "Displays help for a specific command."
|
||||
-- , _tcEffect = TerminalCommandEffectHelp -- \tm -> OneArgument "AN AVAILABLE COMMAND" . getCommandsHelp tm
|
||||
-- }
|
||||
|
||||
getCommandsHelp :: Terminal -> World -> M.Map String [TerminalLine]
|
||||
getCommandsHelp tm w = foldr f mempty $ getCommands tm
|
||||
where
|
||||
f tc =
|
||||
M.insert
|
||||
(_tcString tc)
|
||||
( [ makeTermLine "Command:"
|
||||
, makeColorTermLine commandColor (_tcString tc)
|
||||
, makeTermLine "Aliases:"
|
||||
, makeColorTermLine commandColor (unwords (_tcAlias tc))
|
||||
]
|
||||
++ case argumentHelp tc tm w of
|
||||
(arghelp, Nothing) -> makeTermPara $ _tcHelp tc ++ " " ++ arghelp
|
||||
(arghelp, Just args) ->
|
||||
makeTermPara (_tcHelp tc ++ " " ++ arghelp)
|
||||
++ [makeColorTermLine commandColor $ unwords args]
|
||||
)
|
||||
--getCommandsHelp :: Terminal -> World -> M.Map String [TerminalLine]
|
||||
--getCommandsHelp tm w = foldr f mempty $ getCommands tm
|
||||
-- where
|
||||
-- f tc =
|
||||
-- M.insert
|
||||
-- (_tcString tc)
|
||||
-- ( [ makeTermLine "Command:"
|
||||
-- , makeColorTermLine commandColor (_tcString tc)
|
||||
-- , makeTermLine "Aliases:"
|
||||
-- , makeColorTermLine commandColor (unwords (_tcAlias tc))
|
||||
-- ]
|
||||
-- ++ case argumentHelp tc tm w of
|
||||
-- (arghelp, Nothing) -> makeTermPara $ _tcHelp tc ++ " " ++ arghelp
|
||||
-- (arghelp, Just args) ->
|
||||
-- makeTermPara (_tcHelp tc ++ " " ++ arghelp)
|
||||
-- ++ [makeColorTermLine commandColor $ unwords args]
|
||||
-- )
|
||||
|
||||
commandsCommand :: TerminalCommand
|
||||
commandsCommand =
|
||||
TerminalCommand
|
||||
{ _tcString = "COMMANDS"
|
||||
, _tcAlias = ["COMMAND", "COM"]
|
||||
, _tcHelp = "Displays available commands."
|
||||
, _tcEffect = TerminalCommandEffectCommands
|
||||
}
|
||||
--commandsCommand :: TerminalCommand
|
||||
--commandsCommand =
|
||||
-- TerminalCommand
|
||||
-- { _tcString = "COMMANDS"
|
||||
-- , _tcAlias = ["COMMAND", "COM"]
|
||||
-- , _tcHelp = "Displays available commands."
|
||||
-- , _tcEffect = TerminalCommandEffectCommands
|
||||
-- }
|
||||
|
||||
connectionBlurb :: [TerminalLine]
|
||||
connectionBlurb = connectionBlurbLines []
|
||||
@@ -109,8 +108,28 @@ termSoundLine sid = TLine 0 [] (TmWdWdTermSound sid)
|
||||
termTextColor :: Color
|
||||
termTextColor = greyN 0.9
|
||||
|
||||
getCommands :: Terminal -> [TerminalCommand]
|
||||
getCommands tm = _tmCommands tm -- ++ _tmWriteCommands tm
|
||||
getCommands :: Terminal -> PTE.TrieMap Char (PTE.TrieMap Char [TerminalLine])
|
||||
getCommands = foldMap getCommand . _tmCommands -- tm -- ++ _tmWriteCommands tm
|
||||
|
||||
getCommand :: TCom -> PTE.TrieMap Char (PTE.TrieMap Char [TerminalLine])
|
||||
getCommand = \case
|
||||
TCInfo x z -> PTE.singleton x (PTE.singleton "" (makeTermPara z))
|
||||
TCBase -> helpCommand <> commandsCommand <> quitCommand
|
||||
|
||||
helpCommand :: PTE.TrieMap Char (PTE.TrieMap Char [TerminalLine])
|
||||
helpCommand = PTE.singleton "HELP" (fmap makeTermPara helpStrings)
|
||||
|
||||
helpStrings :: PTE.TrieMap Char String
|
||||
helpStrings = PTE.fromList
|
||||
[("", "THIS TERMINAL PROCESSES TEXT INPUT. INPUT \"COMMANDS\" TO LIST AVAILABLE FUNCTIONALITY.")
|
||||
,("HELP", "BASIC HELP. ACCEPTS A COMMAND AS AN ARGUMENT.")
|
||||
]
|
||||
|
||||
commandsCommand :: PTE.TrieMap Char (PTE.TrieMap Char [TerminalLine])
|
||||
commandsCommand = PTE.singleton "COMMANDS" (PTE.singleton "" [TLine 0 [] TmDisplayCommands])
|
||||
|
||||
quitCommand :: PTE.TrieMap Char (PTE.TrieMap Char [TerminalLine])
|
||||
quitCommand = PTE.singleton "QUIT" (PTE.singleton "" [TLine 0 [] TmWdWdDisconnectTerminal])
|
||||
|
||||
makeTermLine :: String -> TerminalLine
|
||||
makeTermLine = makeColorTermLine termTextColor
|
||||
@@ -127,29 +146,29 @@ makeColorTermLine col str = TLine 1 [TerminalLineConst str col] TmWdId
|
||||
commandColor :: Color
|
||||
commandColor = yellow
|
||||
|
||||
doTerminalCommandEffect :: TerminalCommandEffect -> Terminal -> World -> EffectArguments
|
||||
doTerminalCommandEffect tce = case tce of
|
||||
TerminalCommandArguments eas -> \_ _ -> eas
|
||||
TerminalCommandEffectDamageCoding -> \_ -> OneArgument "a damage type" . getDamageCoding
|
||||
TerminalCommandEffectSensorParameter -> \tm -> OneArgument "a sensor parameter" . sensorInfoMap tm
|
||||
TerminalCommandEffectLinkedObject -> \tm _ -> OneArgument "a linked object" (togglesToEffects tm)
|
||||
TerminalCommandEffectHelp -> \tm -> OneArgument "an available command" . getCommandsHelp tm
|
||||
TerminalCommandEffectNoArgumentsStr str -> \_ _ -> NoArguments (makeTermPara str)
|
||||
TerminalCommandEffectCommands -> \tm _ ->
|
||||
NoArguments
|
||||
( makeTermLine "Available commands:" :
|
||||
makeColorTermPara commandColor (unwords (map _tcString $ getCommands tm))
|
||||
)
|
||||
TerminalCommandEffectSingleCommand eff followingLines -> \_ _ -> NoArguments $ TLine 0 [] (TmWdWdfromWdWd eff) : map makeTermLine followingLines
|
||||
TerminalCommandEffectNone -> \_ _ -> NoArguments []
|
||||
--doTerminalCommandEffect :: TerminalCommandEffect -> Terminal -> World -> EffectArguments
|
||||
--doTerminalCommandEffect tce = case tce of
|
||||
-- TerminalCommandArguments eas -> \_ _ -> eas
|
||||
-- TerminalCommandEffectDamageCoding -> \_ -> OneArgument "a damage type" . getDamageCoding
|
||||
-- TerminalCommandEffectSensorParameter -> \tm -> OneArgument "a sensor parameter" . sensorInfoMap tm
|
||||
-- TerminalCommandEffectLinkedObject -> \tm _ -> OneArgument "a linked object" (togglesToEffects tm)
|
||||
-- TerminalCommandEffectHelp -> \tm -> OneArgument "an available command" . getCommandsHelp tm
|
||||
-- TerminalCommandEffectNoArgumentsStr str -> \_ _ -> NoArguments (makeTermPara str)
|
||||
-- TerminalCommandEffectCommands -> \tm _ ->
|
||||
-- NoArguments
|
||||
-- ( makeTermLine "Available commands:" :
|
||||
-- makeColorTermPara commandColor (unwords (map _tcString $ getCommands tm))
|
||||
-- )
|
||||
-- TerminalCommandEffectSingleCommand eff followingLines -> \_ _ -> NoArguments $ TLine 0 [] (TmWdWdfromWdWd eff) : map makeTermLine followingLines
|
||||
-- TerminalCommandEffectNone -> \_ _ -> NoArguments []
|
||||
|
||||
argumentHelp :: TerminalCommand -> Terminal -> World -> (String, Maybe [String])
|
||||
argumentHelp tc tm w = case doTerminalCommandEffect (_tcEffect tc) tm w of
|
||||
NoArguments{} -> ("Any arguments provided to this command are ignored.", Nothing)
|
||||
OneArgument argtype argm ->
|
||||
( "Expects " ++ argtype ++ " as argument. Available arguments: "
|
||||
, Just (M.keys argm)
|
||||
)
|
||||
--argumentHelp :: TerminalCommand -> Terminal -> World -> (String, Maybe [String])
|
||||
--argumentHelp tc tm w = case doTerminalCommandEffect (_tcEffect tc) tm w of
|
||||
-- NoArguments{} -> ("Any arguments provided to this command are ignored.", Nothing)
|
||||
-- OneArgument argtype argm ->
|
||||
-- ( "Expects " ++ argtype ++ " as argument. Available arguments: "
|
||||
-- , Just (M.keys argm)
|
||||
-- )
|
||||
|
||||
--infoCommand :: String -> TerminalCommand
|
||||
--infoCommand str =
|
||||
@@ -169,24 +188,24 @@ argumentHelp tc tm w = case doTerminalCommandEffect (_tcEffect tc) tm w of
|
||||
-- , _tcEffect = TerminalCommandEffectSingleCommand eff followingLines
|
||||
-- }
|
||||
|
||||
getDamageCoding :: World -> M.Map String [TerminalLine]
|
||||
getDamageCoding = decodedtmap . _sensorCoding . _cwgParams . _cwGen . _cWorld
|
||||
--getDamageCoding :: World -> M.Map String [TerminalLine]
|
||||
--getDamageCoding = decodedtmap . _sensorCoding . _cwgParams . _cwGen . _cWorld
|
||||
|
||||
sensorInfoMap :: Terminal -> World -> M.Map String [TerminalLine]
|
||||
sensorInfoMap tm w =
|
||||
M.fromList
|
||||
[ ("Requirement", getSensor _proxRequirement tm w)
|
||||
, ("Distance", getSensor _proxDist tm w)
|
||||
, ("Currentstatus", getSensor _proxStatus tm w)
|
||||
, ("Paststatus", getSensor _sensToggle tm w)
|
||||
]
|
||||
--sensorInfoMap :: Terminal -> World -> M.Map String [TerminalLine]
|
||||
--sensorInfoMap tm w =
|
||||
-- M.fromList
|
||||
-- [ ("Requirement", getSensor _proxRequirement tm w)
|
||||
-- , ("Distance", getSensor _proxDist tm w)
|
||||
-- , ("Currentstatus", getSensor _proxStatus tm w)
|
||||
-- , ("Paststatus", getSensor _sensToggle tm w)
|
||||
-- ]
|
||||
|
||||
getSensor :: Show a => (Sensor -> a) -> Terminal -> World -> [TerminalLine]
|
||||
getSensor f tm w =
|
||||
maybe
|
||||
[]
|
||||
(makeTermPara . map toLower . show . f)
|
||||
(w ^? cWorld . lWorld . machines . ix (_tmMachineID tm) . mcType . _McSensor)
|
||||
--getSensor :: Show a => (Sensor -> a) -> Terminal -> World -> [TerminalLine]
|
||||
--getSensor f tm w =
|
||||
-- maybe
|
||||
-- []
|
||||
-- (makeTermPara . map toLower . show . f)
|
||||
-- (w ^? cWorld . lWorld . machines . ix (_tmMachineID tm) . mcType . _McSensor)
|
||||
|
||||
toggleCommand :: TerminalCommand
|
||||
toggleCommand =
|
||||
@@ -197,8 +216,8 @@ toggleCommand =
|
||||
, _tcEffect = TerminalCommandEffectLinkedObject -- \tm _ -> OneArgument "A LINKED OBJECT" (togglesToEffects tm)
|
||||
}
|
||||
|
||||
decodedtmap :: M.Map SensorType (PaletteColor, DecorationShape) -> M.Map String [TerminalLine]
|
||||
decodedtmap = M.mapKeys show . M.map ((: []) . makeTermLine . show)
|
||||
--decodedtmap :: M.Map SensorType (PaletteColor, DecorationShape) -> M.Map String [TerminalLine]
|
||||
--decodedtmap = M.mapKeys show . M.map ((: []) . makeTermLine . show)
|
||||
|
||||
sensorCommand :: TerminalCommand
|
||||
sensorCommand =
|
||||
@@ -240,51 +259,57 @@ damageCodeCommand =
|
||||
-- . (tmFutureLines ++.~ tls)
|
||||
-- )
|
||||
|
||||
togglesToEffects :: Terminal -> M.Map String [TerminalLine]
|
||||
togglesToEffects = fmap f . _tmToggles
|
||||
where
|
||||
f tt = [TLine 0 [] $ TmWdWdfromWdWd $ WdWdNegateTrig (_ttTriggerID tt)]
|
||||
--togglesToEffects :: Terminal -> M.Map String [TerminalLine]
|
||||
--togglesToEffects = fmap f . _tmToggles
|
||||
-- where
|
||||
-- f tt = [TLine 0 [] $ TmWdWdfromWdWd $ WdWdNegateTrig (_ttTriggerID tt)]
|
||||
|
||||
simpleTermMessage :: [String] -> Terminal
|
||||
simpleTermMessage strs = defaultTerminal & tmBootLines .~ map makeTermLine strs
|
||||
|
||||
commandFutureLines :: String -> Terminal -> World -> [TerminalLine]
|
||||
commandFutureLines s tm w = fromMaybe [errline "^ Invalid command"] $ do
|
||||
(str, args) <- safeUncons $ words s
|
||||
command <- find (\tc -> _tcString tc == str || str `elem` _tcAlias tc) (getCommands tm)
|
||||
case doTerminalCommandEffect (_tcEffect command) tm w of
|
||||
NoArguments tls -> Just tls
|
||||
OneArgument argtype m ->
|
||||
let setpartial
|
||||
| null (_tmPartialCommand tm) =
|
||||
TLine 0 [] (TmTmSetPartialCommand (Just command)) :
|
||||
makeTermPara ("Expects " ++ argtype ++ " as an argument")
|
||||
| otherwise =
|
||||
TLine 0 [] (TmTmSetPartialCommand Nothing) :
|
||||
makeTermPara "No argument input, cancelling"
|
||||
in Just $
|
||||
fromMaybe setpartial $
|
||||
safeHead args >>= (m M.!?)
|
||||
where
|
||||
errline = makeColorTermLine red
|
||||
--commandFutureLines :: String -> Terminal -> World -> [TerminalLine]
|
||||
--commandFutureLines s tm w = fromMaybe [errline "^ Invalid command"] $ do
|
||||
-- (str, args) <- safeUncons $ words s
|
||||
-- command <- find (\tc -> _tcString tc == str || str `elem` _tcAlias tc) (getCommands tm)
|
||||
-- case doTerminalCommandEffect (_tcEffect command) tm w of
|
||||
-- NoArguments tls -> Just tls
|
||||
-- OneArgument argtype m ->
|
||||
-- let setpartial
|
||||
-- | null (_tmPartialCommand tm) =
|
||||
-- TLine 0 [] (TmTmSetPartialCommand (Just command)) :
|
||||
-- makeTermPara ("Expects " ++ argtype ++ " as an argument")
|
||||
-- | otherwise =
|
||||
-- TLine 0 [] (TmTmSetPartialCommand Nothing) :
|
||||
-- makeTermPara "No argument input, cancelling"
|
||||
-- in Just $
|
||||
-- fromMaybe setpartial $
|
||||
-- safeHead args >>= (m M.!?)
|
||||
-- where
|
||||
-- errline = makeColorTermLine red
|
||||
|
||||
terminalReturnEffect :: Int -> World -> World
|
||||
terminalReturnEffect tmid w = fromMaybe w $ do
|
||||
tm <- w ^? cWorld . lWorld . terminals. ix tmid
|
||||
-- guard $ _tmStatus tm == TerminalTextInput
|
||||
s <- tm ^? tmStatus . tiText
|
||||
let pc = maybe "" (++ " ") $ tm ^? tmPartialCommand . _Just . tcString
|
||||
return $
|
||||
runTerminalString (pc ++ s) tm $
|
||||
runTerminalInput s tm $
|
||||
w
|
||||
& cWorld . lWorld . terminals . ix tmid . tmPartialCommand .~ Nothing
|
||||
& cWorld . lWorld . terminals . ix tmid . tmFutureLines
|
||||
.~ [makeTermLine (pc ++ getPromptTM ++ s)]
|
||||
& cWorld . lWorld . terminals . ix tmid . tmDisplayedLines
|
||||
.:~ (getPromptTM ++ s,termTextColor)
|
||||
|
||||
runTerminalString :: String -> Terminal -> World -> World
|
||||
runTerminalString s tm w =
|
||||
runTerminalInput :: String -> Terminal -> World -> World
|
||||
runTerminalInput s tm w =
|
||||
w & cWorld . lWorld . terminals . ix (_tmID tm)
|
||||
%~ ( --(tmInput .~ TerminalInput{ _tiSel = (0, 0)})
|
||||
(tmFutureLines ++.~ commandFutureLines s tm w)
|
||||
|
||||
(tmFutureLines ++.~ ss)
|
||||
. (tmCommandHistory %~ take 10 . (s :))
|
||||
. (tmStatus .~ TerminalTextInput "")
|
||||
)
|
||||
where
|
||||
ss = fromMaybe [makeTermLine "ERROR: INPUT NOT RECOGNISED"] $ do
|
||||
let args = words s
|
||||
x <- args ^? ix 0
|
||||
teff <- PTE.lookup x (getCommands tm)
|
||||
let y = fromMaybe "" (args ^? ix 1)
|
||||
PTE.lookup y teff
|
||||
|
||||
Reference in New Issue
Block a user