Simplify (data-ify) command arguments
This commit is contained in:
+48
-44
@@ -21,9 +21,7 @@ quitCommand = TerminalCommand
|
||||
{ _tcString = "QUIT"
|
||||
, _tcAlias = ["Q","EXIT","X","SHUTDOWN",""]
|
||||
, _tcHelp = "DISCONNECTS THE TERMINAL."
|
||||
, _tcArgumentType = Nothing
|
||||
, _tcArguments = const (const [])
|
||||
, _tcEffect = \_ _ _ -> Right [TerminalLineEffect 0 disconnectTerminal]
|
||||
, _tcEffect = \_ _ -> NoArguments [TerminalLineEffect 0 disconnectTerminal]
|
||||
}
|
||||
disconnectTerminal :: Terminal -> World -> World
|
||||
disconnectTerminal tm w = w
|
||||
@@ -43,10 +41,17 @@ damageCodeCommand = TerminalCommand
|
||||
{ _tcString = "DAMAGECODE"
|
||||
, _tcAlias = ["DCODE","DC"]
|
||||
, _tcHelp = "DISPLAYS THE SHAPE AND COLOR ASSOCIATED WITH A GIVEN DAMAGE TYPE."
|
||||
, _tcArgumentType = Just "A DAMAGE TYPE"
|
||||
, _tcArguments = \_ -> map (map toUpper . show) . M.keys . _sensorCoding . _genParams
|
||||
, _tcEffect = f
|
||||
, _tcEffect = \_ w -> OneArgument "A DAMAGE TYPE" $ getDamageCoding w
|
||||
-- , _tcArgumentType = Just "A DAMAGE TYPE"
|
||||
-- , _tcArguments = \_ -> map (map toUpper . show) . M.keys . _sensorCoding . _genParams
|
||||
-- , _tcEffect = f
|
||||
}
|
||||
getDamageCoding :: World -> M.Map String [TerminalLine]
|
||||
getDamageCoding = decodedtmap . _sensorCoding . _genParams
|
||||
|
||||
decodedtmap :: M.Map DamageType (PaletteColor,DecorationShape)
|
||||
-> M.Map String [TerminalLine]
|
||||
decodedtmap = M.mapKeys show . M.map ((:[]) . makeTermLine . show)
|
||||
where
|
||||
f args _ w = fromMaybe (Left "") $ do
|
||||
dtype <- safeHead args >>= readMaybe
|
||||
@@ -58,10 +63,20 @@ sensorCommand = TerminalCommand
|
||||
{ _tcString = "SENSOR"
|
||||
, _tcAlias = ["SEN"]
|
||||
, _tcHelp = "ACCESS INFORMATION CONCERNING THE CONNECTED SENSOR."
|
||||
, _tcArgumentType = Just "A SENSOR PARAMETER"
|
||||
, _tcArguments = \_ _ -> ["REQUIREMENT","DISTANCE","CURRENTSTATUS","PASTSTATUS"]
|
||||
, _tcEffect = effectArgMessage sensf
|
||||
, _tcEffect = \tm w -> OneArgument "A SENSOR PARAMETER" (sensorInfoMap 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 toUpper . show . f)
|
||||
(w ^? machines . ix (_tmMachineID tm) . mcSensor)
|
||||
|
||||
|
||||
effectArgMessage :: (String -> Terminal -> World -> Maybe [String])
|
||||
-> [String] -> Terminal -> World -> Either String [TerminalLine]
|
||||
effectArgMessage f args tm w = maybe (Left "") Right $ do
|
||||
@@ -80,36 +95,30 @@ toggleCommand = TerminalCommand
|
||||
{ _tcString = "TOGGLE"
|
||||
, _tcAlias = ["TOG"]
|
||||
, _tcHelp = "PERFORMS A REVERSABLE EFFECT."
|
||||
, _tcArgumentType = Just "AN ATTACHED OBJECT"
|
||||
, _tcArguments = \tm _ -> M.keys $ _tmToggles tm
|
||||
, _tcEffect = togglef
|
||||
, _tcEffect = \tm _ -> OneArgument "A LINKED OBJECT" (togglesToEffects tm)
|
||||
}
|
||||
togglef :: [String] -> Terminal -> World -> Either String [TerminalLine]
|
||||
togglef [] _ _ = Left ""
|
||||
togglef (s:_) tm _ = fromMaybe (Left "") $ do
|
||||
TerminalToggle trid _ <- M.lookup s $ _tmToggles tm
|
||||
Just $ Right [TerminalLineEffect 0 $ \_ -> triggers . ix trid %~ fmap not]
|
||||
togglesToEffects :: Terminal -> M.Map String [TerminalLine]
|
||||
togglesToEffects = fmap f . _tmToggles
|
||||
where
|
||||
f tt = [TerminalLineEffect 0 $ \_ -> triggers . ix (_ttTriggerID tt) %~ fmap not]
|
||||
|
||||
helpCommand :: TerminalCommand
|
||||
helpCommand = TerminalCommand
|
||||
{ _tcString = "HELP"
|
||||
, _tcAlias = ["H","MAN"]
|
||||
, _tcHelp = "DISPLAYS HELP FOR A SPECIFIC COMMAND. TO DISPLAY AVAILABLE COMMANDS USE \"COMMANDS\"."
|
||||
, _tcArgumentType = Just "AN AVAILABLE COMMAND"
|
||||
, _tcArguments = \tm w -> fromMaybe [] $ do
|
||||
commands <- getCommands tm w
|
||||
return $ map _tcString commands
|
||||
, _tcEffect = helpf
|
||||
, _tcEffect = \tm w -> OneArgument "AN AVAILABLE COMMAND" $ getCommandsHelp tm w
|
||||
}
|
||||
helpf :: [String] -> Terminal -> World -> Either String [TerminalLine]
|
||||
helpf [] tm w = helpf ["HELP"] tm w
|
||||
helpf (str:_) tm w = maybe (Left "") Right $ do
|
||||
commands <- getCommands tm w
|
||||
command <- find (\tc -> _tcString tc == str || str `elem` _tcAlias tc) commands
|
||||
return $
|
||||
[makeTermLine ("COMMAND:" ++ _tcString command)
|
||||
,makeTermLine ("ALIASES:" ++ unwords (_tcAlias command)) ]
|
||||
++ makeTermPara (_tcHelp command ++ " " ++ argumentHelp (_tcArgumentType command))
|
||||
getCommandsHelp :: Terminal -> World -> M.Map String [TerminalLine]
|
||||
getCommandsHelp tm w = fromMaybe mempty $ do
|
||||
tcs <- getCommands tm w
|
||||
return $ foldr f mempty tcs
|
||||
where
|
||||
f tc = M.insert (_tcString tc)
|
||||
( [makeTermLine ("COMMAND:" ++ _tcString tc)
|
||||
,makeTermLine ("ALIASES:" ++ unwords (_tcAlias tc)) ]
|
||||
++ (makeTermPara $ _tcHelp tc)
|
||||
)
|
||||
getCommands :: Terminal -> World -> Maybe [TerminalCommand]
|
||||
getCommands tm w = do
|
||||
commands1 <- w ^? terminals . ix (_tmID tm) . tmScrollCommands
|
||||
@@ -149,9 +158,7 @@ infoCommand str = TerminalCommand
|
||||
{ _tcString = "INFORMATION"
|
||||
, _tcAlias = ["INFO","I"]
|
||||
, _tcHelp = "DISPLAYS INFORMATION CONCERNING THE TERMINAL."
|
||||
, _tcArgumentType = Nothing
|
||||
, _tcArguments = const (const [])
|
||||
, _tcEffect = \ _ _ _ -> Right ( makeTermPara str)
|
||||
, _tcEffect = \_ _ -> NoArguments (makeTermPara str)
|
||||
}
|
||||
|
||||
commandsCommand :: TerminalCommand
|
||||
@@ -159,9 +166,7 @@ commandsCommand = TerminalCommand
|
||||
{ _tcString = "COMMANDS"
|
||||
, _tcAlias = ["COMMAND","COM"]
|
||||
, _tcHelp = "DISPLAYS AVAILABLE COMMANDS."
|
||||
, _tcArgumentType = Nothing
|
||||
, _tcArguments = const $ const []
|
||||
, _tcEffect = \_ tm w -> Right
|
||||
, _tcEffect = \tm w -> NoArguments
|
||||
( makeTermLine "AVAILABLE COMMANDS:"
|
||||
: makeTermPara (unwords (maybe [""] (map _tcString) $ getCommands tm w))
|
||||
)
|
||||
@@ -172,9 +177,7 @@ singleCommand followingLines command aliases htext eff = TerminalCommand
|
||||
{_tcString = command
|
||||
,_tcAlias = aliases
|
||||
,_tcHelp = htext
|
||||
,_tcArgumentType = Nothing
|
||||
, _tcArguments = const $ const []
|
||||
,_tcEffect = \_ _ _ -> Right $ TerminalLineEffect 0 (const eff) : map makeTermLine followingLines
|
||||
,_tcEffect = \_ _ -> NoArguments $ TerminalLineEffect 0 (const eff) : map makeTermLine followingLines
|
||||
}
|
||||
|
||||
doTerminalEffectLB :: Terminal -> World -> World
|
||||
@@ -193,10 +196,11 @@ commandFutureLines s tm w = fromMaybe [] $ do
|
||||
commands <- getCommands tm w
|
||||
(str,args) <- safeUncons $ words s
|
||||
command <- find (\tc -> _tcString tc == str || str `elem` _tcAlias tc) commands
|
||||
case _tcEffect command args tm w of
|
||||
Right tls -> Just tls
|
||||
Left err -> Just [makeColorTermLine red
|
||||
("^ INVALID ARGUMENT: EXPECTS "++fromJust (_tcArgumentType command)++ err) ]
|
||||
case _tcEffect command tm w of
|
||||
NoArguments tls -> Just tls
|
||||
OneArgument argtype m -> case args of
|
||||
(arg:_) -> M.lookup arg m
|
||||
[] -> Just [makeColorTermLine red $ "^ INVALID ARGUMENT: EXPECTS "++ argtype ]
|
||||
|
||||
doTerminalEffect' :: String -> Terminal -> World -> World
|
||||
doTerminalEffect' s tm w = fromMaybe (w & badinput) $ do
|
||||
|
||||
Reference in New Issue
Block a user