-- |
-- SPDX-License-Identifier: BSD-3-Clause
--
-- Types for styling custom entity attributes
module Swarm.Game.Scenario.Style where

import Data.Aeson
import Data.Colour.Palette.BrewerSet (Kolor)
import Data.Colour.SRGB (sRGB24read, toSRGB24)
import Data.Set (Set)
import Data.Text (Text)
import Data.Text qualified as T
import GHC.Generics (Generic)
import Swarm.Game.Entity.Cosmetic

data StyleFlag
  = Standout
  | Italic
  | Strikethrough
  | Underline
  | ReverseVideo
  | Blink
  | Dim
  | Bold
  deriving (StyleFlag -> StyleFlag -> Bool
(StyleFlag -> StyleFlag -> Bool)
-> (StyleFlag -> StyleFlag -> Bool) -> Eq StyleFlag
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: StyleFlag -> StyleFlag -> Bool
== :: StyleFlag -> StyleFlag -> Bool
$c/= :: StyleFlag -> StyleFlag -> Bool
/= :: StyleFlag -> StyleFlag -> Bool
Eq, Eq StyleFlag
Eq StyleFlag =>
(StyleFlag -> StyleFlag -> Ordering)
-> (StyleFlag -> StyleFlag -> Bool)
-> (StyleFlag -> StyleFlag -> Bool)
-> (StyleFlag -> StyleFlag -> Bool)
-> (StyleFlag -> StyleFlag -> Bool)
-> (StyleFlag -> StyleFlag -> StyleFlag)
-> (StyleFlag -> StyleFlag -> StyleFlag)
-> Ord StyleFlag
StyleFlag -> StyleFlag -> Bool
StyleFlag -> StyleFlag -> Ordering
StyleFlag -> StyleFlag -> StyleFlag
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: StyleFlag -> StyleFlag -> Ordering
compare :: StyleFlag -> StyleFlag -> Ordering
$c< :: StyleFlag -> StyleFlag -> Bool
< :: StyleFlag -> StyleFlag -> Bool
$c<= :: StyleFlag -> StyleFlag -> Bool
<= :: StyleFlag -> StyleFlag -> Bool
$c> :: StyleFlag -> StyleFlag -> Bool
> :: StyleFlag -> StyleFlag -> Bool
$c>= :: StyleFlag -> StyleFlag -> Bool
>= :: StyleFlag -> StyleFlag -> Bool
$cmax :: StyleFlag -> StyleFlag -> StyleFlag
max :: StyleFlag -> StyleFlag -> StyleFlag
$cmin :: StyleFlag -> StyleFlag -> StyleFlag
min :: StyleFlag -> StyleFlag -> StyleFlag
Ord, Int -> StyleFlag -> ShowS
[StyleFlag] -> ShowS
StyleFlag -> String
(Int -> StyleFlag -> ShowS)
-> (StyleFlag -> String)
-> ([StyleFlag] -> ShowS)
-> Show StyleFlag
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> StyleFlag -> ShowS
showsPrec :: Int -> StyleFlag -> ShowS
$cshow :: StyleFlag -> String
show :: StyleFlag -> String
$cshowList :: [StyleFlag] -> ShowS
showList :: [StyleFlag] -> ShowS
Show, (forall x. StyleFlag -> Rep StyleFlag x)
-> (forall x. Rep StyleFlag x -> StyleFlag) -> Generic StyleFlag
forall x. Rep StyleFlag x -> StyleFlag
forall x. StyleFlag -> Rep StyleFlag x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. StyleFlag -> Rep StyleFlag x
from :: forall x. StyleFlag -> Rep StyleFlag x
$cto :: forall x. Rep StyleFlag x -> StyleFlag
to :: forall x. Rep StyleFlag x -> StyleFlag
Generic)

styleFlagJsonOptions :: Options
styleFlagJsonOptions :: Options
styleFlagJsonOptions =
  Options
defaultOptions
    { sumEncoding = UntaggedValue
    }

instance FromJSON StyleFlag where
  parseJSON :: Value -> Parser StyleFlag
parseJSON = Options -> Value -> Parser StyleFlag
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON Options
styleFlagJsonOptions

instance ToJSON StyleFlag where
  toJSON :: StyleFlag -> Value
toJSON = Options -> StyleFlag -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON Options
styleFlagJsonOptions

-- | Hexadecimal color notation.
-- May include a leading hash symbol (see 'Data.Colour.SRGB.sRGB24read').
newtype HexColor = HexColor Text
  deriving (HexColor -> HexColor -> Bool
(HexColor -> HexColor -> Bool)
-> (HexColor -> HexColor -> Bool) -> Eq HexColor
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: HexColor -> HexColor -> Bool
== :: HexColor -> HexColor -> Bool
$c/= :: HexColor -> HexColor -> Bool
/= :: HexColor -> HexColor -> Bool
Eq, Eq HexColor
Eq HexColor =>
(HexColor -> HexColor -> Ordering)
-> (HexColor -> HexColor -> Bool)
-> (HexColor -> HexColor -> Bool)
-> (HexColor -> HexColor -> Bool)
-> (HexColor -> HexColor -> Bool)
-> (HexColor -> HexColor -> HexColor)
-> (HexColor -> HexColor -> HexColor)
-> Ord HexColor
HexColor -> HexColor -> Bool
HexColor -> HexColor -> Ordering
HexColor -> HexColor -> HexColor
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: HexColor -> HexColor -> Ordering
compare :: HexColor -> HexColor -> Ordering
$c< :: HexColor -> HexColor -> Bool
< :: HexColor -> HexColor -> Bool
$c<= :: HexColor -> HexColor -> Bool
<= :: HexColor -> HexColor -> Bool
$c> :: HexColor -> HexColor -> Bool
> :: HexColor -> HexColor -> Bool
$c>= :: HexColor -> HexColor -> Bool
>= :: HexColor -> HexColor -> Bool
$cmax :: HexColor -> HexColor -> HexColor
max :: HexColor -> HexColor -> HexColor
$cmin :: HexColor -> HexColor -> HexColor
min :: HexColor -> HexColor -> HexColor
Ord, Int -> HexColor -> ShowS
[HexColor] -> ShowS
HexColor -> String
(Int -> HexColor -> ShowS)
-> (HexColor -> String) -> ([HexColor] -> ShowS) -> Show HexColor
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HexColor -> ShowS
showsPrec :: Int -> HexColor -> ShowS
$cshow :: HexColor -> String
show :: HexColor -> String
$cshowList :: [HexColor] -> ShowS
showList :: [HexColor] -> ShowS
Show, (forall x. HexColor -> Rep HexColor x)
-> (forall x. Rep HexColor x -> HexColor) -> Generic HexColor
forall x. Rep HexColor x -> HexColor
forall x. HexColor -> Rep HexColor x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. HexColor -> Rep HexColor x
from :: forall x. HexColor -> Rep HexColor x
$cto :: forall x. Rep HexColor x -> HexColor
to :: forall x. Rep HexColor x -> HexColor
Generic, Maybe HexColor
Value -> Parser [HexColor]
Value -> Parser HexColor
(Value -> Parser HexColor)
-> (Value -> Parser [HexColor])
-> Maybe HexColor
-> FromJSON HexColor
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser HexColor
parseJSON :: Value -> Parser HexColor
$cparseJSONList :: Value -> Parser [HexColor]
parseJSONList :: Value -> Parser [HexColor]
$comittedField :: Maybe HexColor
omittedField :: Maybe HexColor
FromJSON, [HexColor] -> Value
[HexColor] -> Encoding
HexColor -> Bool
HexColor -> Value
HexColor -> Encoding
(HexColor -> Value)
-> (HexColor -> Encoding)
-> ([HexColor] -> Value)
-> ([HexColor] -> Encoding)
-> (HexColor -> Bool)
-> ToJSON HexColor
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: HexColor -> Value
toJSON :: HexColor -> Value
$ctoEncoding :: HexColor -> Encoding
toEncoding :: HexColor -> Encoding
$ctoJSONList :: [HexColor] -> Value
toJSONList :: [HexColor] -> Value
$ctoEncodingList :: [HexColor] -> Encoding
toEncodingList :: [HexColor] -> Encoding
$comitField :: HexColor -> Bool
omitField :: HexColor -> Bool
ToJSON)

data CustomAttr = CustomAttr
  { CustomAttr -> String
name :: String
  , CustomAttr -> Maybe HexColor
fg :: Maybe HexColor
  , CustomAttr -> Maybe HexColor
bg :: Maybe HexColor
  , CustomAttr -> Maybe (Set StyleFlag)
style :: Maybe (Set StyleFlag)
  }
  deriving (CustomAttr -> CustomAttr -> Bool
(CustomAttr -> CustomAttr -> Bool)
-> (CustomAttr -> CustomAttr -> Bool) -> Eq CustomAttr
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CustomAttr -> CustomAttr -> Bool
== :: CustomAttr -> CustomAttr -> Bool
$c/= :: CustomAttr -> CustomAttr -> Bool
/= :: CustomAttr -> CustomAttr -> Bool
Eq, Int -> CustomAttr -> ShowS
[CustomAttr] -> ShowS
CustomAttr -> String
(Int -> CustomAttr -> ShowS)
-> (CustomAttr -> String)
-> ([CustomAttr] -> ShowS)
-> Show CustomAttr
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CustomAttr -> ShowS
showsPrec :: Int -> CustomAttr -> ShowS
$cshow :: CustomAttr -> String
show :: CustomAttr -> String
$cshowList :: [CustomAttr] -> ShowS
showList :: [CustomAttr] -> ShowS
Show, (forall x. CustomAttr -> Rep CustomAttr x)
-> (forall x. Rep CustomAttr x -> CustomAttr) -> Generic CustomAttr
forall x. Rep CustomAttr x -> CustomAttr
forall x. CustomAttr -> Rep CustomAttr x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. CustomAttr -> Rep CustomAttr x
from :: forall x. CustomAttr -> Rep CustomAttr x
$cto :: forall x. Rep CustomAttr x -> CustomAttr
to :: forall x. Rep CustomAttr x -> CustomAttr
Generic, Maybe CustomAttr
Value -> Parser [CustomAttr]
Value -> Parser CustomAttr
(Value -> Parser CustomAttr)
-> (Value -> Parser [CustomAttr])
-> Maybe CustomAttr
-> FromJSON CustomAttr
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser CustomAttr
parseJSON :: Value -> Parser CustomAttr
$cparseJSONList :: Value -> Parser [CustomAttr]
parseJSONList :: Value -> Parser [CustomAttr]
$comittedField :: Maybe CustomAttr
omittedField :: Maybe CustomAttr
FromJSON)

instance ToJSON CustomAttr where
  toJSON :: CustomAttr -> Value
toJSON =
    Options -> CustomAttr -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON
      Options
defaultOptions
        { omitNothingFields = True
        }

-- | Must specify either a foreground or background color;
-- just a style is not sufficient.
toHifiPair :: CustomAttr -> Maybe (WorldAttr, PreservableColor)
toHifiPair :: CustomAttr -> Maybe (WorldAttr, PreservableColor)
toHifiPair (CustomAttr String
n Maybe HexColor
maybeFg Maybe HexColor
maybeBg Maybe (Set StyleFlag)
_) =
  (WorldAttr, Maybe PreservableColor)
-> Maybe (WorldAttr, PreservableColor)
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a.
Applicative f =>
(WorldAttr, f a) -> f (WorldAttr, a)
sequenceA (String -> WorldAttr
WorldAttr String
n, (HexColor -> TrueColor) -> ColorLayers HexColor -> PreservableColor
forall a b. (a -> b) -> ColorLayers a -> ColorLayers b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HexColor -> TrueColor
conv (ColorLayers HexColor -> PreservableColor)
-> Maybe (ColorLayers HexColor) -> Maybe PreservableColor
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (ColorLayers HexColor)
c)
 where
  c :: Maybe (ColorLayers HexColor)
c = case (Maybe HexColor
maybeFg, Maybe HexColor
maybeBg) of
    (Just HexColor
f, Just HexColor
b) -> ColorLayers HexColor -> Maybe (ColorLayers HexColor)
forall a. a -> Maybe a
Just (ColorLayers HexColor -> Maybe (ColorLayers HexColor))
-> ColorLayers HexColor -> Maybe (ColorLayers HexColor)
forall a b. (a -> b) -> a -> b
$ HexColor -> HexColor -> ColorLayers HexColor
forall a. a -> a -> ColorLayers a
FgAndBg HexColor
f HexColor
b
    (Just HexColor
f, Maybe HexColor
Nothing) -> ColorLayers HexColor -> Maybe (ColorLayers HexColor)
forall a. a -> Maybe a
Just (ColorLayers HexColor -> Maybe (ColorLayers HexColor))
-> ColorLayers HexColor -> Maybe (ColorLayers HexColor)
forall a b. (a -> b) -> a -> b
$ HexColor -> ColorLayers HexColor
forall a. a -> ColorLayers a
FgOnly HexColor
f
    (Maybe HexColor
Nothing, Just HexColor
b) -> ColorLayers HexColor -> Maybe (ColorLayers HexColor)
forall a. a -> Maybe a
Just (ColorLayers HexColor -> Maybe (ColorLayers HexColor))
-> ColorLayers HexColor -> Maybe (ColorLayers HexColor)
forall a b. (a -> b) -> a -> b
$ HexColor -> ColorLayers HexColor
forall a. a -> ColorLayers a
BgOnly HexColor
b
    (Maybe HexColor
Nothing, Maybe HexColor
Nothing) -> Maybe (ColorLayers HexColor)
forall a. Maybe a
Nothing

  conv :: HexColor -> TrueColor
conv (HexColor Text
x) = RGBColor -> TrueColor
Triple (RGBColor -> TrueColor) -> RGBColor -> TrueColor
forall a b. (a -> b) -> a -> b
$ Colour Double -> RGBColor
forall b. (RealFrac b, Floating b) => Colour b -> RGBColor
toSRGB24 Colour Double
kolor
   where
    kolor :: Kolor
    kolor :: Colour Double
kolor = String -> Colour Double
forall b. (Ord b, Floating b) => String -> Colour b
sRGB24read (String -> Colour Double) -> String -> Colour Double
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
x