{-
	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 <http://www.gnu.org/licenses/>.
-}
{- |
 [@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,
--	resignTag,
--	restartTag,
--	rollBackTag,
--	saveTag,
	setTag,
--	swapTag,
--	alternationTag,
--	printArgs,
--	setArgs,
--	commands,
	usageMessage,
-- * Functions
	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

-- | Used to distinguish a command from a move.
commandPrefix :: Char
commandPrefix :: Char
commandPrefix	= Char
':'

-- | Input-format.
hintTag :: String
hintTag :: String
hintTag		= String
"hint"

-- | Input-format.
printTag :: String
printTag :: String
printTag	= String
"print"

-- | Input-format.
quitTag :: String
quitTag :: String
quitTag		= String
"quit"

-- | Input-format.
resignTag :: String
resignTag :: String
resignTag	= String
"resign"

-- | Input-format.
restartTag :: String
restartTag :: String
restartTag	= String
"restart"

-- | Input-format.
rollBackTag :: String
rollBackTag :: String
rollBackTag	= String
"rollBack"

-- | Input-format.
saveTag :: String
saveTag :: String
saveTag		= String
"save"

-- | Input-format.
setTag :: String
setTag :: String
setTag		= String
"set"

-- | Input-format.
swapTag :: String
swapTag :: String
swapTag		= String
"swap"

-- | The symbol used to denote alternation.
alternationTag :: String
alternationTag :: String
alternationTag	= String
"|"

-- | Show the arguments of a command.
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

-- | The format of the argument to the command 'set'.
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>"
 ]

-- | The commands that a user may issue.
data Command x y
	= Hint						-- ^ Request a move-suggestion.
	| Print UI.PrintObject.PrintObject		-- ^ Show the value of the specified object.
	| Quit						-- ^ Terminate this application.
	| Resign					-- ^ Admit defeat.
	| Restart					-- ^ Abandon the current game, & start afresh.
	| RollBack (Maybe Component.Move.NMoves)	-- ^ Roll-back the specified number of plies.
	| Save						-- ^ Persist the current game-state.
	| Set UI.SetObject.SetObject			-- ^ I.E. mutate a configuration-value.
	| Swap						-- ^ Swap evaluation-options between the two sides.
	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
_			= ()

-- | The data required to compose the usage-message for the available /command/s.
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"
	)
 ]

-- | A message defining the syntax of the available /command/s.
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]

-- | Reads a /command/.
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')	-- Include a specific abbreviation.
	[(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

-- | Shows a /command/.
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

-- | 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 :: 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