module BishBosh.Attribute.ColourScheme (
ColourScheme(
getDarkPieceColour,
getLightPieceColour,
getDarkSquareColour,
getLightSquareColour
),
tag,
) where
import qualified BishBosh.Attribute.PhysicalColour as Attribute.PhysicalColour
import qualified BishBosh.Data.Exception as Data.Exception
import qualified BishBosh.Text.ShowList as Text.ShowList
import qualified Control.Arrow
import qualified Control.DeepSeq
import qualified Control.Exception
import qualified Data.Default
import qualified Text.XML.HXT.Arrow.Pickle as HXT
tag :: String
tag = "colourScheme"
darkPieceColourTag, darkSquareColourTag, lightPieceColourTag, lightSquareColourTag :: String
[darkPieceColourTag, darkSquareColourTag, lightPieceColourTag, lightSquareColourTag] = [showString brightness $ showString component "Colour" | brightness <- ["dark", "light"], component <- ["Piece", "Square"]]
data ColourScheme = MkColourScheme {
getDarkPieceColour :: Attribute.PhysicalColour.PhysicalColour,
getLightPieceColour :: Attribute.PhysicalColour.PhysicalColour,
getDarkSquareColour :: Attribute.PhysicalColour.PhysicalColour,
getLightSquareColour :: Attribute.PhysicalColour.PhysicalColour
} deriving Eq
instance Control.DeepSeq.NFData ColourScheme where
rnf MkColourScheme {
getDarkPieceColour = darkPieceColour,
getLightPieceColour = lightPieceColour,
getDarkSquareColour = darkSquareColour,
getLightSquareColour = lightSquareColour
} = Control.DeepSeq.rnf (
darkPieceColour,
lightPieceColour,
darkSquareColour,
lightSquareColour
)
instance Show ColourScheme where
showsPrec _ MkColourScheme {
getDarkPieceColour = darkPieceColour,
getLightPieceColour = lightPieceColour,
getDarkSquareColour = darkSquareColour,
getLightSquareColour = lightSquareColour
} = Text.ShowList.showsAssociationList' $ map (Control.Arrow.second shows) [
(
darkPieceColourTag,
darkPieceColour
), (
lightPieceColourTag,
lightPieceColour
), (
darkSquareColourTag,
darkSquareColour
), (
lightSquareColourTag,
lightSquareColour
)
]
instance Data.Default.Default ColourScheme where
def = MkColourScheme {
getDarkPieceColour = Attribute.PhysicalColour.blue,
getLightPieceColour = Attribute.PhysicalColour.yellow,
getDarkSquareColour = Attribute.PhysicalColour.black,
getLightSquareColour = Attribute.PhysicalColour.white
}
instance HXT.XmlPickler ColourScheme where
xpickle = HXT.xpElem tag . HXT.xpWrap (
\(a, b, c, d) -> mkColourScheme a b c d,
\MkColourScheme {
getDarkPieceColour = darkPieceColour,
getLightPieceColour = lightPieceColour,
getDarkSquareColour = darkSquareColour,
getLightSquareColour = lightSquareColour
} -> (
darkPieceColour,
lightPieceColour,
darkSquareColour,
lightSquareColour
)
) $ HXT.xp4Tuple (
getDarkPieceColour def `HXT.xpDefault` HXT.xpAttr darkPieceColourTag HXT.xpickle
) (
getLightPieceColour def `HXT.xpDefault` HXT.xpAttr lightPieceColourTag HXT.xpickle
) (
getDarkSquareColour def `HXT.xpDefault` HXT.xpAttr darkSquareColourTag HXT.xpickle
) (
getLightSquareColour def `HXT.xpDefault` HXT.xpAttr lightSquareColourTag HXT.xpickle
) where
def :: ColourScheme
def = Data.Default.def
mkColourScheme
:: Attribute.PhysicalColour.PhysicalColour
-> Attribute.PhysicalColour.PhysicalColour
-> Attribute.PhysicalColour.PhysicalColour
-> Attribute.PhysicalColour.PhysicalColour
-> ColourScheme
mkColourScheme darkPieceColour lightPieceColour darkSquareColour lightSquareColour
| darkPieceColour `elem` bgColours = Control.Exception.throw . Data.Exception.mkIncompatibleData . showString "BishBosh.Attribute.ColourScheme.mkColourScheme:\t" . showString darkPieceColourTag . Text.ShowList.showsAssociation . shows darkPieceColour . showString " must differ from the physical colour of both squares; " $ shows bgColours "."
| lightPieceColour `elem` bgColours = Control.Exception.throw . Data.Exception.mkIncompatibleData . showString "BishBosh.Attribute.ColourScheme.mkColourScheme:\t" . showString lightPieceColourTag . Text.ShowList.showsAssociation . shows lightPieceColour . showString " must differ from the physical colour of both squares; " $ shows bgColours "."
| darkSquareColour == lightSquareColour = Control.Exception.throw . Data.Exception.mkIncompatibleData . showString "BishBosh.Attribute.ColourScheme.mkColourScheme:\tthe physical colours of " . shows lightSquareColourTag . showString " & " $ shows darkSquareColourTag ", must differ."
| otherwise = MkColourScheme {
getDarkPieceColour = darkPieceColour,
getLightPieceColour = lightPieceColour,
getDarkSquareColour = darkSquareColour,
getLightSquareColour = lightSquareColour
}
where
bgColours = [darkSquareColour, lightSquareColour]