module BishBosh.UI.Command (
Command(..),
commandPrefix,
printTag,
setTag,
usageMessage,
readsCommand,
showsCommand,
autoComplete
) where
import qualified BishBosh.Component.Move as Component.Move
import qualified BishBosh.Input.Options as Input.Options
import qualified BishBosh.Input.SearchOptions as Input.SearchOptions
import qualified BishBosh.UI.PrintObject as UI.PrintObject
import qualified BishBosh.UI.SetObject as UI.SetObject
import qualified Control.Arrow
import qualified Control.DeepSeq
import qualified Data.Char
import qualified Data.List
import qualified Data.List.Extra
import qualified Data.Maybe
import qualified Text.Printf
commandPrefix :: Char
commandPrefix = ':'
hintTag :: String
hintTag = "hint"
printTag :: String
printTag = "print"
quitTag :: String
quitTag = "quit"
resignTag :: String
resignTag = "resign"
restartTag :: String
restartTag = "restart"
rollBackTag :: String
rollBackTag = "rollBack"
saveTag :: String
saveTag = "save"
setTag :: String
setTag = "set"
swapTag :: String
swapTag = "swap"
alternationTag :: String
alternationTag = "|"
printArgs :: String
printArgs = Data.List.intercalate alternationTag $ map show UI.PrintObject.range
setArgs :: String
setArgs = Data.List.intercalate alternationTag [
showString Input.SearchOptions.searchDepthTag " <Int>"
]
data Command x y
= Hint
| Print UI.PrintObject.PrintObject
| Quit
| Resign
| Restart
| RollBack (Maybe Component.Move.NMoves)
| Save
| Set UI.SetObject.SetObject
| Swap
deriving (Eq, Show)
instance Control.DeepSeq.NFData (Command x y) where
rnf (Print printObject) = Control.DeepSeq.rnf printObject
rnf (Set setObject) = Control.DeepSeq.rnf setObject
rnf _ = ()
commands :: [(String, Maybe String, String)]
commands = [
(
hintTag,
Nothing,
"Request a move-suggestion"
), (
printTag,
Just printArgs,
"Print the specified data"
), (
quitTag,
Nothing,
"Quit"
), (
resignTag,
Nothing,
"Resign"
), (
restartTag,
Nothing,
"Restart the game, preserving the current configuration"
), (
rollBackTag,
Just "[<Int>]",
"The number of plies to roll-back"
), (
saveTag,
Nothing,
"Save"
), (
setTag,
Just setArgs,
showString "Mutate " Input.Options.tag
), (
swapTag,
Nothing,
showString "Swap " $ shows Input.Options.tag " between the two sides"
)
]
usageMessage :: String
usageMessage = showString (
Text.Printf.printf (showString indent $ showChar ' ' format) commandFieldWidth "Command" objectFieldWidth "Object" "Definition"
) $ concatMap (
\(command, maybeArg, definition) -> Text.Printf.printf (
showChar '\n' . showString indent . showChar commandPrefix $ showString format "."
) commandFieldWidth command objectFieldWidth (
Data.Maybe.fromMaybe "" maybeArg
) definition
) commands where
indent, format :: String
indent = replicate 2 ' '
format = "%-*s%-*s%s"
commandFieldWidth, objectFieldWidth :: Int
commandFieldWidth = succ . maximum $ map (\(tag, _, _) -> length tag) commands
objectFieldWidth = succ $ maximum [length arg | (_, Just arg, _) <- commands]
readsCommand :: String -> Either String (Command x y, String)
readsCommand s = case Control.Arrow.first Data.List.Extra.lower `map` lex s of
[("hint", s')] -> Right (Hint, s')
[("help", s')] -> Right (Print UI.PrintObject.Help, s')
[("print", s')] -> case reads $ UI.PrintObject.autoComplete s' of
[pair] -> Right $ Control.Arrow.first Print pair
_ -> Left . showString "failed to read the object to " . showString printTag . showString " from " . shows s' . showString ". Usage: \"" . showChar commandPrefix . showString printTag . showChar ' ' $ showString printArgs "\""
[("quit", s')] -> Right (Quit, s')
[("resign", s')] -> Right (Resign, s')
[("restart", s')] -> Right (Restart, s')
[("save", s')] -> Right (Save, s')
[("set", s')] -> case reads $ UI.SetObject.autoComplete s' of
[pair] -> Right $ Control.Arrow.first Set pair
_ -> Left . showString "failed to read the object to " . showString setTag . showString " from " . shows s' . showString ". Usage: \"" . showChar commandPrefix . showString setTag . showString " (" $ showString setArgs ")\""
[("rollback", s')] -> case Data.List.Extra.trimStart s' of
[] -> Right (RollBack Nothing, s')
s'' -> case reads s'' of
[(nMoves, s''')] -> Right (RollBack (Just nMoves), s''')
_ -> Left . showString "failed to read the integral number of moves to " . showString rollBackTag . showString " from " $ show s''
[("swap", s')] -> Right (Swap, s')
[] -> Left "no command received"
_ -> Left . showString "failed to read a command from " $ show s
showsCommand :: Command x y -> ShowS
showsCommand command = case command of
Hint -> showString hintTag
Print printObject -> showString printTag . showChar ' ' . shows printObject
Quit -> showString quitTag
Resign -> showString resignTag
Restart -> showString restartTag
RollBack maybeNMoves -> showString rollBackTag . Data.Maybe.maybe id (\nMoves -> showChar ' ' . shows nMoves) maybeNMoves
Save -> showString saveTag
Set setObject -> showString setTag . showChar ' ' . shows setObject
Swap -> showString swapTag
autoComplete :: ShowS
autoComplete = uncurry (++) . Control.Arrow.first (
\word -> case [
tag |
(tag, _, _) <- ("help", Nothing, "") : commands,
Data.List.Extra.lower word `Data.List.isPrefixOf` Data.List.Extra.lower tag
] of
[tag] -> tag
_ -> word
) . break Data.Char.isSpace . Data.List.Extra.trimStart