module BishBosh.Input.NativeUIOptions(
ScreenCoordinates,
NativeUIOptions(
getBoardMagnification,
getColourScheme
),
tag,
boardMagnificationTag,
mkNativeUIOptions
) where
import Control.Arrow((***))
import qualified BishBosh.Attribute.ColourScheme as Attribute.ColourScheme
import qualified BishBosh.Data.Exception as Data.Exception
import qualified BishBosh.Text.ShowList as Text.ShowList
import qualified Control.DeepSeq
import qualified Control.Exception
import qualified Data.Default
import qualified Text.XML.HXT.Arrow.Pickle as HXT
tag :: String
tag = "nativeUIOptions"
boardMagnificationTag :: String
boardMagnificationTag = "boardMagnification"
nRowsTag :: String
nRowsTag = "nRows"
nColumnsTag :: String
nColumnsTag = "nColumns"
type ScreenCoordinates row column = (row, column)
data NativeUIOptions row column = MkNativeUIOptions {
getBoardMagnification :: ScreenCoordinates row column,
getColourScheme :: Attribute.ColourScheme.ColourScheme
} deriving Eq
instance (
Control.DeepSeq.NFData column,
Control.DeepSeq.NFData row
) => Control.DeepSeq.NFData (NativeUIOptions row column) where
rnf MkNativeUIOptions {
getBoardMagnification = boardMagnification,
getColourScheme = colourScheme
} = Control.DeepSeq.rnf (
boardMagnification,
colourScheme
)
instance (Show row, Show column) => Show (NativeUIOptions row column) where
showsPrec _ MkNativeUIOptions {
getBoardMagnification = boardMagnification,
getColourScheme = colourScheme
} = Text.ShowList.showsAssociationList' [
(
boardMagnificationTag,
shows boardMagnification
), (
Attribute.ColourScheme.tag,
shows colourScheme
)
]
instance (Num row, Num column) => Data.Default.Default (NativeUIOptions row column) where
def = MkNativeUIOptions {
getBoardMagnification = (1, 1),
getColourScheme = Data.Default.def
}
instance (
HXT.XmlPickler column,
HXT.XmlPickler row,
Integral column,
Integral row,
Show column,
Show row
) => HXT.XmlPickler (NativeUIOptions row column) where
xpickle = HXT.xpElem tag . HXT.xpWrap (
uncurry mkNativeUIOptions,
\MkNativeUIOptions {
getBoardMagnification = boardMagnification,
getColourScheme = colourScheme
} -> (
boardMagnification,
colourScheme
)
) $ HXT.xpPair (
getBoardMagnification def `HXT.xpDefault` HXT.xpElem boardMagnificationTag (
HXT.xpAttr nRowsTag HXT.xpickle `HXT.xpPair` HXT.xpAttr nColumnsTag HXT.xpickle
)
) (
getColourScheme def `HXT.xpDefault` HXT.xpickle
) where
def = Data.Default.def
mkNativeUIOptions :: (
Integral column,
Integral row,
Show column,
Show row
)
=> ScreenCoordinates row column
-> Attribute.ColourScheme.ColourScheme
-> NativeUIOptions row column
mkNativeUIOptions boardMagnification colourScheme
| uncurry (||) $ (
(< 1) *** (< 1)
) boardMagnification = Control.Exception.throw . Data.Exception.mkOutOfBounds . showString "BishBosh.Input.NativeUIOptions.mkNativeUIOptions:\t" . showString boardMagnificationTag . Text.ShowList.showsAssociation $ shows boardMagnification " must both exceed zero."
| uncurry (||) $ (
even *** even
) boardMagnification = Control.Exception.throw . Data.Exception.mkInvalidDatum . showString "BishBosh.Input.NativeUIOptions.mkNativeUIOptions:\t" . showString boardMagnificationTag . Text.ShowList.showsAssociation $ shows boardMagnification " must both be odd."
| otherwise = MkNativeUIOptions {
getBoardMagnification = boardMagnification,
getColourScheme = colourScheme
}