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