{-
	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 [CECP](https://www.chessprogramming.org/Chess_Engine_Communication_Protocol)-features.
-}

module BishBosh.Input.CECPFeatures(
-- * Types
-- ** Type-synonyms
--	Key,
--	Value,
	Feature,
--	Transformation,
-- ** Data-types
	CECPFeatures(
--		MkCECPFeatures
		getFeatures
--		getDone
	),
-- * Constants
	tag,
	featureTag,
	analyseTag,
	coloursTag,
--	debugTag,
--	doneTag,
	drawTag,
--	egtTag,
--	excludeTag,
--	highlightTag,
	icsTag,
--	memoryTag,
--	mynameTag,
	nameTag,
	npsTag,
	optionTag,
	pauseTag,
	pingTag,
	playotherTag,
--	reuseTag,
--	sanTag,
	setboardTag,
--	sigintTag,
--	sigtermTag,
--	smpTag,
	timeTag,
	usermoveTag,
--	variantsTag,
--	showsFeatureSeparator,
--	showsKVSeparator,
	resolution,
	inputWidget,
	sliderWidget,
-- * Functions
-- ** Constructors
	mkCECPFeatures,
-- ** Mutators
	prependFeature,
	deleteFeature,
	updateFeature,
-- ** Predicates
	isFeatureDisabled
) where

import			BishBosh.Data.Bool()	-- For 'HXT.XmlPickler Bool'.
import			Control.Arrow((|||))
import qualified	BishBosh.Data.Exception		as Data.Exception
import qualified	BishBosh.Data.Foldable		as Data.Foldable
import qualified	BishBosh.Text.ShowList		as Text.ShowList
import qualified	Control.DeepSeq
import qualified	Control.Exception
import qualified	Data.Char
import qualified	Data.Default
import qualified	Data.List
import qualified	Data.Maybe
import qualified	Text.XML.HXT.Arrow.Pickle	as HXT

-- | Used to qualify XML.
tag :: String
tag :: String
tag		= String
"cecpFeatures"

-- | Used to qualify XML.
featureTag :: String
featureTag :: String
featureTag	= String
"feature"

-- | Self-documentation.
type Key	= String

-- | Each feature-value can be either an @Int@ (also used to represent @Bool@ values), or an arbitrary @String@.
type Value	= Either Int String

-- | Self-documentation.
type Feature	= (Key, Value)

-- | Tags the feature which defines whether the GUI may request "analyse" mode.
analyseTag :: Key
analyseTag :: String
analyseTag	= String
"analyze"

-- | Tags the feature which defines whether the GUI may request that a specific player move next.
coloursTag :: Key
coloursTag :: String
coloursTag	= String
"colors"

-- | Tags the feature which defines whether the engine may send debug information to the GUI.
debugTag :: Key
debugTag :: String
debugTag	= String
"debug"

-- | The tag used to terminate the feature-list.
doneTag :: Key
doneTag :: String
doneTag		= String
"done"

-- | Tags the feature which defines whether the GUI may send the "draw" command.
drawTag :: Key
drawTag :: String
drawTag		= String
"draw"

-- | Tags the feature which defines whether the GUI may send the "egtpath" command.
egtTag :: Key
egtTag :: String
egtTag		= String
"egt"

-- | Tags the feature which defines whether the GUI may send the "exclude" command.
excludeTag :: Key
excludeTag :: String
excludeTag	= String
"exclude"

-- | Tags the feature which defines whether the GUI may send the "lift", "put" & "hover" commands.
highlightTag :: Key
highlightTag :: String
highlightTag	= String
"highlight"

-- | Tag the feature which defines whether the GUI should inform the engine whether it's on a chess-server.
icsTag :: Key
icsTag :: String
icsTag		= String
"ics"

-- | Tags the feature which defines whether the GUI can request that the engine cap memory-use.
memoryTag :: Key
memoryTag :: String
memoryTag	= String
"memory"

-- | Tags the feature which defines the engine's name to the GUI.
mynameTag :: Key
mynameTag :: String
mynameTag	= String
"myname"

-- | Tags the feature which defines whether the GUI can tell the engine the opponent's name.
nameTag :: Key
nameTag :: String
nameTag		= String
"name"

-- | Tags the feature which defines whether the GUI can limit thinking-time to a number of nodes searched.
npsTag :: Key
npsTag :: String
npsTag		= String
"nps"

-- |
optionTag :: Key
optionTag :: String
optionTag	= String
"option"

-- | Tags the feature which defines whether the GUI may send the "pause" command.
pauseTag :: Key
pauseTag :: String
pauseTag	= String
"pause"

-- | Tags the feature which defines whether the GUI may send a "ping" command.
pingTag :: Key
pingTag :: String
pingTag		= String
"ping"

-- | Tags the feature which defines whether the GUI may send the "playother" command.
playotherTag :: Key
playotherTag :: String
playotherTag	= String
"playother"

-- | Tags the feature which defines whether the GUI may reuse this engine for multiple games.
reuseTag :: Key
reuseTag :: String
reuseTag	= String
"reuse"

-- | Tags the feature which defines whether the GUI may send moves in "SAN" rather than "PureCoordinate" notation.
sanTag :: Key
sanTag :: String
sanTag		= String
"san"

-- | Tags the feature which defines whether the GUI may send the "setboard" command.
setboardTag :: Key
setboardTag :: String
setboardTag	= String
"setboard"

-- | Tags the feature which defines whether the GUI may send the engine a "SIGINT".
sigintTag :: Key
sigintTag :: String
sigintTag	= String
"sigint"

-- | Tags the feature which defines whether the GUI may send the engine a "SIGTERM".
sigtermTag :: Key
sigtermTag :: String
sigtermTag	= String
"sigterm"

-- | Tags the feature which defines whether the GUI may cap the number of cores used by the engine.
smpTag :: Key
smpTag :: String
smpTag		= String
"smp"

-- | Tags the feature which defines whether the GUI may adjust the engine's move-timer.
timeTag :: Key
timeTag :: String
timeTag		= String
"time"

-- | Tags the feature which defines whether the GUI should prefix move-commands to facilitate identification.
usermoveTag :: Key
usermoveTag :: String
usermoveTag	= String
"usermove"

-- | Tags the feature which defines the supported variants of chess.
variantsTag :: Key
variantsTag :: String
variantsTag	= String
"variants"

-- | Defines the feature-separator used for streaming.
showsFeatureSeparator :: ShowS
showsFeatureSeparator :: ShowS
showsFeatureSeparator	= Char -> ShowS
showChar Char
' '

-- | Defines the key-value separator used for streaming features.
showsKVSeparator :: ShowS
showsKVSeparator :: ShowS
showsKVSeparator	= Char -> ShowS
showChar Char
'='

-- | The resolution of sliders depicted in the GUI.
resolution :: Int
resolution :: Int
resolution	= Int
1000

-- | The string sent to xboard, to request an input widget.
inputWidget :: String
inputWidget :: String
inputWidget	= String
"-string"

-- | The string sent to xboard, to request a slider-widget.
sliderWidget :: String
sliderWidget :: String
sliderWidget	= String
"-slider"

-- | Defines CECP-features.
data CECPFeatures	= MkCECPFeatures {
	CECPFeatures -> [Feature]
getFeatures	:: [Feature],	-- ^ The list of features.
	CECPFeatures -> Bool
getDone		:: Bool		-- ^ Whether the GUI should assume that all features have been received, or wait until a timeout before proceeding.
} deriving CECPFeatures -> CECPFeatures -> Bool
(CECPFeatures -> CECPFeatures -> Bool)
-> (CECPFeatures -> CECPFeatures -> Bool) -> Eq CECPFeatures
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CECPFeatures -> CECPFeatures -> Bool
$c/= :: CECPFeatures -> CECPFeatures -> Bool
== :: CECPFeatures -> CECPFeatures -> Bool
$c== :: CECPFeatures -> CECPFeatures -> Bool
Eq

instance Control.DeepSeq.NFData CECPFeatures where
	rnf :: CECPFeatures -> ()
rnf MkCECPFeatures {
		getFeatures :: CECPFeatures -> [Feature]
getFeatures	= [Feature]
features,
		getDone :: CECPFeatures -> Bool
getDone		= Bool
done
	} = ([Feature], Bool) -> ()
forall a. NFData a => a -> ()
Control.DeepSeq.rnf ([Feature]
features, Bool
done)

instance Show CECPFeatures where
	showsPrec :: Int -> CECPFeatures -> ShowS
showsPrec Int
_ MkCECPFeatures {
		getFeatures :: CECPFeatures -> [Feature]
getFeatures	= [Feature]
features,
		getDone :: CECPFeatures -> Bool
getDone		= Bool
done
	} = ShowS -> ShowS -> ShowS -> [ShowS] -> ShowS
Text.ShowList.showsDelimitedList ShowS
showsFeatureSeparator ShowS
forall a. a -> a
id ShowS
forall a. a -> a
id (
		(Feature -> ShowS) -> [Feature] -> [ShowS]
forall a b. (a -> b) -> [a] -> [b]
map (
			\(String
k, Either Int String
v) -> String -> ShowS
showString String
k ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
showsKVSeparator ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> ShowS) -> (String -> ShowS) -> Either Int String -> ShowS
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Int -> ShowS
forall a. Show a => a -> ShowS
shows {-Int-} (\String
s -> Char -> ShowS
showChar Char
'"' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
s ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
'"') Either Int String
v
		) [Feature]
features
	 ) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
showsFeatureSeparator ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
doneTag ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
showsKVSeparator ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
forall a. Show a => a -> ShowS
shows (if Bool
done then (Int
1 :: Int) else Int
0)

instance Data.Default.Default CECPFeatures where
	def :: CECPFeatures
def = MkCECPFeatures :: [Feature] -> Bool -> CECPFeatures
MkCECPFeatures {
		getFeatures :: [Feature]
getFeatures	= let
			Either Int b
false : Either Int b
true : [Either Int b]
_	= (Int -> Either Int b) -> [Int] -> [Either Int b]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Either Int b
forall a b. a -> Either a b
Left [Int
0 ..]

			mkCommaSeparatedList :: [String] -> Either a String
mkCommaSeparatedList	= String -> Either a String
forall a b. b -> Either a b
Right (String -> Either a String)
-> ([String] -> String) -> [String] -> Either a String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
Data.List.intercalate String
","
		in [
			(
				String
analyseTag,	Either Int String
forall b. Either Int b
false			-- Whether xboard may send the "analyze" command, should the user asks for analysis mode.
			), (
				String
coloursTag,	Either Int String
forall b. Either Int b
false			-- Whether xboard may send the obsolete "white" and "black" commands.
			), (
				String
drawTag,	Either Int String
forall b. Either Int b
true			-- Whether xboard may send the "draw" command, should the user request one.
			), (
				String
debugTag,	Either Int String
forall b. Either Int b
false			-- Whether the engine may send debug-output (prefixed by '#') to xboard.
			), (
				String
egtTag,		[String] -> Either Int String
forall a. [String] -> Either a String
mkCommaSeparatedList []	-- Whether xboard can send the "egtpath" command to define the path to end-game tables.
			), (
				String
excludeTag,	Either Int String
forall b. Either Int b
false			-- Whether xboard can send the "exclude" command to control which moves are searched.
			), (
				String
highlightTag,	Either Int String
forall b. Either Int b
false			-- Whether xboard can send "lift", "put" and "hover" commands to the engine.
			), (
				String
icsTag,		Either Int String
forall b. Either Int b
true			-- Whether xboard should inform us whether it is playing on a chess-server.
			), (
				String
memoryTag,	Either Int String
forall b. Either Int b
false			-- Whether xboard can send the "memory" command to cap memory-use.
			), (
				String
mynameTag,	String -> Either Int String
forall a b. b -> Either a b
Right String
"BishBosh"	-- Defines the name xboard uses for in-window banners, in the PGN-tags of saved game-files, & when sending the "name" command to another engine.
			), (
				String
nameTag,	Either Int String
forall b. Either Int b
true			-- Whether xboard may send the "name" command to inform us of the opponent's name.
			), (
				String
npsTag,		Either Int String
forall b. Either Int b
false			-- Whether xboard may send the "nps" command, to limit thinking by the number of nodes searched rather than time.
			), (
				String
pauseTag,	Either Int String
forall b. Either Int b
true			-- Whether xboard may send the "pause" command.
			), (
				String
pingTag,	Either Int String
forall b. Either Int b
true			-- Whether xboard may send the "ping" command.
			), (
				String
playotherTag,	Either Int String
forall b. Either Int b
true			-- Whether xboard may send the "playother" command.
			), (
				String
reuseTag,	Either Int String
forall b. Either Int b
true			-- Whether xboard may reuse this engine for multiple games.
			), (
				String
sanTag,		Either Int String
forall b. Either Int b
false			-- Whether xboard sends moves in "Standard Algebraic Notation" rather than "PureCoordinate".
			), (
				String
setboardTag,	Either Int String
forall b. Either Int b
true			-- Whether xboard may send the "setboard" command, to define the board.
			), (
				String
sigintTag,	Either Int String
forall b. Either Int b
false			-- Whether xboard may send SIGINT, which it might if it believes the engine isn't listening.
			), (
				String
sigtermTag,	Either Int String
forall b. Either Int b
true			-- Whether xboard may send SIGTERM, which it does shortly after the "quit" command.
			), (
				String
smpTag,		Either Int String
forall b. Either Int b
true			-- Whether xboard can send the "cores" command to limit the number of CPU-cores.
			), (
				String
timeTag,	Either Int String
forall b. Either Int b
false			-- Whether xboard may send the "time" and "otim" commands to update the engine's clocks.
			), (
				String
usermoveTag,	Either Int String
forall b. Either Int b
true			-- Whether xboard should send the "usermove"-prefix to moves.
			), (
				String
variantsTag,	[String] -> Either Int String
forall a. [String] -> Either a String
mkCommaSeparatedList [
					String
"normal"
				]					-- The set of acceptable game-variants.
			)
		],
		getDone :: Bool
getDone	= Bool
True	-- Terminate the feature-list.
	 }

instance HXT.XmlPickler CECPFeatures where
	xpickle :: PU CECPFeatures
xpickle	= CECPFeatures -> PU CECPFeatures -> PU CECPFeatures
forall a. Eq a => a -> PU a -> PU a
HXT.xpDefault CECPFeatures
def (PU CECPFeatures -> PU CECPFeatures)
-> (PU ([Feature], Bool) -> PU CECPFeatures)
-> PU ([Feature], Bool)
-> PU CECPFeatures
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> PU CECPFeatures -> PU CECPFeatures
forall a. String -> PU a -> PU a
HXT.xpElem String
tag (PU CECPFeatures -> PU CECPFeatures)
-> (PU ([Feature], Bool) -> PU CECPFeatures)
-> PU ([Feature], Bool)
-> PU CECPFeatures
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Feature], Bool) -> CECPFeatures,
 CECPFeatures -> ([Feature], Bool))
-> PU ([Feature], Bool) -> PU CECPFeatures
forall a b. (a -> b, b -> a) -> PU a -> PU b
HXT.xpWrap (
		([Feature] -> Bool -> CECPFeatures)
-> ([Feature], Bool) -> CECPFeatures
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [Feature] -> Bool -> CECPFeatures
mkCECPFeatures,	-- Construct.
		\MkCECPFeatures {
			getFeatures :: CECPFeatures -> [Feature]
getFeatures	= [Feature]
features,
			getDone :: CECPFeatures -> Bool
getDone		= Bool
done
		} -> ([Feature]
features, Bool
done)	-- Deconstruct.
	 ) (PU ([Feature], Bool) -> PU CECPFeatures)
-> PU ([Feature], Bool) -> PU CECPFeatures
forall a b. (a -> b) -> a -> b
$ (
		PU Feature -> PU [Feature]
forall a. PU a -> PU [a]
HXT.xpList (PU Feature -> PU [Feature])
-> (PU Feature -> PU Feature) -> PU Feature -> PU [Feature]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> PU Feature -> PU Feature
forall a. String -> PU a -> PU a
HXT.xpElem String
featureTag (PU Feature -> PU [Feature]) -> PU Feature -> PU [Feature]
forall a b. (a -> b) -> a -> b
$ String -> PU String
HXT.xpTextAttr String
"key" PU String -> PU (Either Int String) -> PU Feature
forall a b. PU a -> PU b -> PU (a, b)
`HXT.xpPair` (String -> Either Int String, Either Int String -> String)
-> PU String -> PU (Either Int String)
forall a b. (a -> b, b -> a) -> PU a -> PU b
HXT.xpWrap (
			\String
s -> case ReadS Int
forall a. Read a => ReadS a
reads String
s of
				[(Int
i, String
"")]	-> Int -> Either Int String
forall a b. a -> Either a b
Left Int
i
				[(Int, String)]
_		-> String -> Either Int String
forall a b. b -> Either a b
Right String
s,
			\Either Int String
value -> Char -> ShowS
showChar Char
'"' ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ (Int -> ShowS
forall a. Show a => a -> ShowS
shows (Int -> ShowS) -> (String -> ShowS) -> Either Int String -> ShowS
forall (a :: * -> * -> *) b d c.
ArrowChoice a =>
a b d -> a c d -> a (Either b c) d
||| String -> ShowS
showString) Either Int String
value String
"\""
		 ) (
			String -> PU String -> PU String
forall a. String -> PU a -> PU a
HXT.xpAttr String
"value" PU String
HXT.xpText0
		 )
	 ) PU [Feature] -> PU Bool -> PU ([Feature], Bool)
forall a b. PU a -> PU b -> PU (a, b)
`HXT.xpPair` (
		CECPFeatures -> Bool
getDone CECPFeatures
def Bool -> PU Bool -> PU Bool
forall a. Eq a => a -> PU a -> PU a
`HXT.xpDefault` String -> PU Bool -> PU Bool
forall a. String -> PU a -> PU a
HXT.xpAttr String
doneTag PU Bool
forall a. XmlPickler a => PU a
HXT.xpickle
	 ) where
		def :: CECPFeatures
def	= CECPFeatures
forall a. Default a => a
Data.Default.def

-- | Smart constructor.
mkCECPFeatures :: [Feature] -> Bool -> CECPFeatures
mkCECPFeatures :: [Feature] -> Bool -> CECPFeatures
mkCECPFeatures [Feature]
features Bool
done
	| Just (String
key, Either Int String
_)	<- (Feature -> Bool) -> [Feature] -> Maybe Feature
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
Data.List.find (
		Bool -> Bool
not (Bool -> Bool) -> (Feature -> Bool) -> Feature -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
Data.Char.isAlpha (String -> Bool) -> (Feature -> String) -> Feature -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Feature -> String
forall a b. (a, b) -> a
fst {-key-}
	) [Feature]
features	= Exception -> CECPFeatures
forall a e. Exception e => e -> a
Control.Exception.throw (Exception -> CECPFeatures)
-> (String -> Exception) -> String -> CECPFeatures
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Exception
Data.Exception.mkInvalidDatum (String -> Exception) -> ShowS -> String -> Exception
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"BishBosh.Input.CECPFeatures.mkCECPFeatures:\tinvalid key" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
Text.ShowList.showsAssociation (String -> CECPFeatures) -> String -> CECPFeatures
forall a b. (a -> b) -> a -> b
$ String -> ShowS
forall a. Show a => a -> ShowS
shows String
key String
"."
	| Just (String
_, Either Int String
value)	<- (Feature -> Bool) -> [Feature] -> Maybe Feature
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
Data.List.find (
		(
			Bool -> Int -> Bool
forall a b. a -> b -> a
const Bool
False (Int -> Bool) -> (String -> Bool) -> Either Int String -> Bool
forall (a :: * -> * -> *) b d c.
ArrowChoice a =>
a b d -> a c d -> a (Either b c) d
||| (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
"\"\n\r") {-Prevent command-injection-}
		) (Either Int String -> Bool)
-> (Feature -> Either Int String) -> Feature -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Feature -> Either Int String
forall a b. (a, b) -> b
snd {-value-}
	) [Feature]
features	= Exception -> CECPFeatures
forall a e. Exception e => e -> a
Control.Exception.throw (Exception -> CECPFeatures)
-> (String -> Exception) -> String -> CECPFeatures
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Exception
Data.Exception.mkInvalidDatum (String -> Exception) -> ShowS -> String -> Exception
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"BishBosh.Input.CECPFeatures.mkCECPFeatures:\tinvalid value" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
Text.ShowList.showsAssociation (String -> CECPFeatures) -> String -> CECPFeatures
forall a b. (a -> b) -> a -> b
$ Either Int String -> ShowS
forall a. Show a => a -> ShowS
shows Either Int String
value String
"."
	| Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
duplicateFeatures	= Exception -> CECPFeatures
forall a e. Exception e => e -> a
Control.Exception.throw (Exception -> CECPFeatures)
-> (String -> Exception) -> String -> CECPFeatures
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Exception
Data.Exception.mkDuplicateData (String -> Exception) -> ShowS -> String -> Exception
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"BishBosh.Input.CECPFeatures.mkCECPFeatures:\tduplicate features " (String -> CECPFeatures) -> String -> CECPFeatures
forall a b. (a -> b) -> a -> b
$ [String] -> ShowS
forall a. Show a => a -> ShowS
shows [String]
duplicateFeatures String
"."
	| Bool
otherwise	= MkCECPFeatures :: [Feature] -> Bool -> CECPFeatures
MkCECPFeatures {
		getFeatures :: [Feature]
getFeatures	= [Feature]
features,
		getDone :: Bool
getDone		= Bool
done
	}
	where
		duplicateFeatures :: [String]
duplicateFeatures	= [String] -> [String]
forall (foldable :: * -> *) a.
(Foldable foldable, Ord a) =>
foldable a -> [a]
Data.Foldable.findDuplicates ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (Feature -> String) -> [Feature] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Feature -> String
forall a b. (a, b) -> a
fst {-key-} [Feature]
features

-- | Self-documentation.
type Transformation	= CECPFeatures -> CECPFeatures

{- |
	* Prepends the specified feature.

	* CAVEAT: this may create a duplicate key.
-}
prependFeature :: Feature -> Transformation
prependFeature :: Feature -> Transformation
prependFeature Feature
feature cecpFeatures :: CECPFeatures
cecpFeatures@MkCECPFeatures {
	getFeatures :: CECPFeatures -> [Feature]
getFeatures	= [Feature]
features
} = CECPFeatures
cecpFeatures {
	getFeatures :: [Feature]
getFeatures	= Feature
feature Feature -> [Feature] -> [Feature]
forall a. a -> [a] -> [a]
: [Feature]
features
}

-- | Deletes the specified feature.
deleteFeature :: Feature -> Transformation
deleteFeature :: Feature -> Transformation
deleteFeature feature :: Feature
feature@(String
key, Either Int String
value) cecpFeatures :: CECPFeatures
cecpFeatures@MkCECPFeatures {
	getFeatures :: CECPFeatures -> [Feature]
getFeatures	= [Feature]
features
} = CECPFeatures
cecpFeatures {
	getFeatures :: [Feature]
getFeatures	= (Feature -> Bool) -> [Feature] -> [Feature]
forall a. (a -> Bool) -> [a] -> [a]
filter (
		(Feature -> Bool) -> Int -> Feature -> Bool
forall a b. a -> b -> a
const (
			(String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
key) (String -> Bool) -> (Feature -> String) -> Feature -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Feature -> String
forall a b. (a, b) -> a
fst
		) (Int -> Feature -> Bool)
-> (String -> Feature -> Bool)
-> Either Int String
-> Feature
-> Bool
forall (a :: * -> * -> *) b d c.
ArrowChoice a =>
a b d -> a c d -> a (Either b c) d
||| (Feature -> Bool) -> String -> Feature -> Bool
forall a b. a -> b -> a
const (Feature -> Feature -> Bool
forall a. Eq a => a -> a -> Bool
/= Feature
feature) {-N.B.: string-valued features must also match the specified value, to account for possibility of duplicates-} (Either Int String -> Feature -> Bool)
-> Either Int String -> Feature -> Bool
forall a b. (a -> b) -> a -> b
$ Either Int String
value
	) [Feature]
features
}

{- |
	* Prepends the specified feature.

	* CAVEAT: deletes all similarly named features.
-}
updateFeature :: Feature -> Transformation
updateFeature :: Feature -> Transformation
updateFeature Feature
feature	= Feature -> Transformation
prependFeature Feature
feature Transformation -> Transformation -> Transformation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Feature -> Transformation
deleteFeature Feature
feature

-- | Predicate.
isFeatureDisabled :: Key -> CECPFeatures -> Bool
isFeatureDisabled :: String -> CECPFeatures -> Bool
isFeatureDisabled String
key MkCECPFeatures {
	getFeatures :: CECPFeatures -> [Feature]
getFeatures	= [Feature]
features
} = Bool
-> (Either Int String -> Bool) -> Maybe (Either Int String) -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
Data.Maybe.maybe (
	Exception -> Bool
forall a e. Exception e => e -> a
Control.Exception.throw (Exception -> Bool) -> (String -> Exception) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Exception
Data.Exception.mkSearchFailure (String -> Exception) -> ShowS -> String -> Exception
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"BishBosh.Input.CECPFeatures.isFeatureDisabled:\t" (String -> Bool) -> String -> Bool
forall a b. (a -> b) -> a -> b
$ String -> ShowS
forall a. Show a => a -> ShowS
shows String
key String
" not found."
 ) (
	(Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) (Int -> Bool) -> (String -> Bool) -> Either Int String -> Bool
forall (a :: * -> * -> *) b d c.
ArrowChoice a =>
a b d -> a c d -> a (Either b c) d
||| String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null
 ) (Maybe (Either Int String) -> Bool)
-> Maybe (Either Int String) -> Bool
forall a b. (a -> b) -> a -> b
$ String -> [Feature] -> Maybe (Either Int String)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
key [Feature]
features