{-# LANGUAGE LambdaCase #-}
{-
Copyright (C) 2018 Dr. Alistair Ward
This file is part of BishBosh.
BishBosh is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
BishBosh is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with BishBosh. If not, see .
-}
{- |
[@AUTHOR@] Dr. Alistair Ward
[@DESCRIPTION@] Defines the commands a user can issue.
-}
module BishBosh.UI.Command (
-- * Types
-- ** Data-types
Command(..),
-- * Constants
-- commandPrefix,
-- hintTag,
printTag,
-- quitTag,
-- reportTag,
-- resignTag,
-- restartTag,
-- rollBackTag,
-- saveTag,
setTag,
-- swapTag,
-- alternationTag,
-- printArgs,
-- reportArgs,
-- setArgs,
-- commands,
usageMessage,
-- * Functions
readsCommand,
showsCommand,
issueCommand,
autoComplete
) where
import qualified BishBosh.Data.List
import qualified BishBosh.Input.Options as Input.Options
import qualified BishBosh.Property.ExtendedPositionDescription as Property.ExtendedPositionDescription
import qualified BishBosh.Text.AutoComplete as Text.AutoComplete
import qualified BishBosh.Type.Count as Type.Count
import qualified BishBosh.UI.PrintObject as UI.PrintObject
import qualified BishBosh.UI.ReportObject as UI.ReportObject
import qualified BishBosh.UI.SetObject as UI.SetObject
import qualified Control.Arrow
import qualified Control.DeepSeq
import qualified Data.List
import qualified Data.List.Extra
import qualified Data.Maybe
import qualified Text.Printf
-- | Used to distinguish a command from a move.
commandPrefix :: Char
commandPrefix = ':'
-- | Input-format.
hintTag :: String
hintTag = "hint"
-- | Input-format.
printTag :: String
printTag = "print"
-- | Input-format.
quitTag :: String
quitTag = "quit"
-- | Input-format.
reportTag :: String
reportTag = "report"
-- | Input-format.
resignTag :: String
resignTag = "resign"
-- | Input-format.
restartTag :: String
restartTag = "restart"
-- | Input-format.
rollBackTag :: String
rollBackTag = "rollBack"
-- | Input-format.
saveTag :: String
saveTag = "save"
-- | Input-format.
setTag :: String
setTag = "set"
-- | Input-format.
swapTag :: String
swapTag = "swap"
-- | The symbol used to denote alternation.
alternationTag :: String
alternationTag = "|"
-- | Show the arguments of a command.
printArgs :: String
printArgs = Data.List.intercalate alternationTag $ map show UI.PrintObject.range
-- | Show the arguments of a command.
reportArgs :: String
reportArgs = Data.List.intercalate alternationTag $ map show UI.ReportObject.range
-- | The format of the argument to the runtime-command /set/.
setArgs :: String
setArgs = Data.List.intercalate alternationTag [
showString Property.ExtendedPositionDescription.tag " ",
showString UI.SetObject.searchDepthTag " "
]
-- | The sum-type of commands that a user may issue.
data Command
= Hint -- ^ Request a move-suggestion.
| Print UI.PrintObject.PrintObject -- ^ Print the requested static data.
| Quit -- ^ Terminate this application.
| Report UI.ReportObject.ReportObject -- ^ Report on the requested dynamic data.
| Resign -- ^ Admit defeat.
| Restart -- ^ Abandon the current game, & start afresh.
| RollBack (Maybe Type.Count.NPlies) -- ^ Roll-back the optionally specified number of plies.
| Save -- ^ Persist the current game-state.
| Set UI.SetObject.SetObject -- ^ I.E. mutate something.
| Swap -- ^ Swap options between the two sides; which causes the players to swap sides.
deriving (Eq, Show)
instance Control.DeepSeq.NFData Command where
rnf (Print printObject) = Control.DeepSeq.rnf printObject
rnf (Set setObject) = Control.DeepSeq.rnf setObject
rnf _ = ()
-- | The data required to compose the usage-message for the available /command/s.
commands :: [(String, Maybe String, String)]
commands = [
(
hintTag,
Nothing,
"Request a move-suggestion"
), (
printTag,
Just printArgs,
"Print the specified static data"
), (
quitTag,
Nothing,
"Terminate this application"
), (
reportTag,
Just reportArgs,
"Report on the specified dynamic data"
), (
resignTag,
Nothing,
"Admit defeat"
), (
restartTag,
Nothing,
"Restart the game, preserving the current configuration"
), (
rollBackTag,
Just "[]",
"The optionally specified number of plies to roll-back"
), (
saveTag,
Nothing,
"Persist the current game-state"
), (
setTag,
Just setArgs,
"Mutate something"
), (
swapTag,
Nothing,
showString "Swap " $ shows Input.Options.tag " between the two sides"
)
]
-- | A message defining the syntax of the available /command/s.
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]
-- | Reads a /command/.
readsCommand :: String -> Either String (Command, String)
readsCommand [] = Left . showString "null command received; specify one of " . show $ map (\(tag, _, _) -> tag) commands
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') -- Include a specific abbreviation.
[("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')
[("report", s')] -> case reads $ UI.ReportObject.autoComplete s' of
[pair] -> Right $ Control.Arrow.first Report pair
_ -> Left . showString "failed to read the object to " . showString reportTag . showString " from " . shows s' . showString ". Usage: \"" . showChar commandPrefix . showString reportTag . showChar ' ' $ showString reportArgs "\""
[("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
[(nPlies, s''')]
| nPlies <= 0 -> Left . showString "the specified number of plies (" $ shows nPlies ") must exceed zero"
| otherwise -> Right (RollBack (Just $ fromInteger nPlies), s''')
_ -> Left . showString "failed to read the integral number of plies to " . showString rollBackTag . showString " from " $ show s''
[("swap", s')] -> Right (Swap, s')
(command, _) : _ -> Left . showString "failed to read a command from " . shows s . showString "; did you mean " . show . BishBosh.Data.List.findClosest command $ map (\(tag, _, _) -> tag) commands
_ -> Left "no command received"
-- | Shows a /command/.
showsCommand :: Command -> ShowS
showsCommand = \case
Hint -> showString hintTag
Print printObject -> showString printTag . showChar ' ' . shows printObject
Quit -> showString quitTag
Report reportObject -> showString reportTag . showChar ' ' . shows reportObject
Resign -> showString resignTag
Restart -> showString restartTag
RollBack maybeNPlies -> showString rollBackTag . Data.Maybe.maybe id (\nPlies -> showChar ' ' . shows nPlies) maybeNPlies
Save -> showString saveTag
Set setObject -> showString setTag . showChar ' ' . shows setObject
Swap -> showString swapTag
-- | Show the specified command in the format required by this application's parser.
issueCommand :: Command -> ShowS
issueCommand command = showChar commandPrefix . shows command
-- | Replace the first word of the specified string with the name of a command of which it is an unambiguous case-insensitive prefix.
autoComplete :: ShowS
autoComplete = Text.AutoComplete.autoComplete $ "help" : map (
\(tag, _, _) -> tag
) commands