summaryrefslogtreecommitdiff
path: root/src/WWW
diff options
context:
space:
mode:
Diffstat (limited to 'src/WWW')
-rw-r--r--src/WWW/Colors.hs140
-rw-r--r--src/WWW/Colors/Hex.hs34
-rw-r--r--src/WWW/Colors/Instances.hs23
-rw-r--r--src/WWW/Colors/QQ.hs27
4 files changed, 224 insertions, 0 deletions
diff --git a/src/WWW/Colors.hs b/src/WWW/Colors.hs
new file mode 100644
index 0000000..b52aea7
--- /dev/null
+++ b/src/WWW/Colors.hs
@@ -0,0 +1,140 @@
+{-# LANGUAGE QuasiQuotes #-}
+module WWW.Colors
+ ( Gruvbox (..)
+ , gruvboxVar
+ , gruvboxDark
+ , gruvboxDarkH
+ , gruvboxDarkS
+ , gruvboxLight
+ , gruvboxLightH
+ , gruvboxLightS
+ ) where
+
+import Data.Colour
+import Data.String
+import Diagrams.Attributes
+
+import WWW.Colors.Instances()
+import WWW.Colors.QQ
+
+
+data Gruvbox a = Gruvbox
+ { _bg, _red, _green, _yellow, _blue, _purple, _aqua, _gray, _gray', _red', _green', _yellow', _blue', _purple', _aqua', _fg, _bg0h, _bg0, _bg0s, _bg1, _bg2, _bg3, _bg4, _gray'', _orange, _fg4, _fg3, _fg2, _fg1, _fg0, _orange' :: !a
+ } deriving stock (Foldable, Functor, Eq, Show, Traversable)
+
+gruvboxVar :: IsString s => Gruvbox s
+gruvboxVar = Gruvbox
+ { _bg = "gb_bg"
+ , _red = "gb_red"
+ , _green = "gb_green"
+ , _yellow = "gb_yellow"
+ , _blue = "gb_blue"
+ , _purple = "gb_purple"
+ , _aqua = "gb_aqua"
+ , _gray = "gb_gray"
+ , _gray' = "gb_gray'"
+ , _red' = "gb_red'"
+ , _green' = "gb_green'"
+ , _yellow' = "gb_yellow'"
+ , _blue' = "gb_blue'"
+ , _purple' = "gb_purple'"
+ , _aqua' = "gb_aqua'"
+ , _fg = "gb_fg"
+ , _bg0h = "gb_bg0h"
+ , _bg0 = "gb_bg0"
+ , _bg0s = "gb_bg0s"
+ , _bg1 = "gb_bg1"
+ , _bg2 = "gb_bg2"
+ , _bg3 = "gb_bg3"
+ , _bg4 = "gb_bg4"
+ , _gray'' = "gb_gray''"
+ , _orange = "gb_orange"
+ , _fg4 = "gb_fg4"
+ , _fg3 = "gb_fg3"
+ , _fg2 = "gb_fg2"
+ , _fg1 = "gb_fg1"
+ , _fg0 = "gb_fg0"
+ , _orange' = "gb_orange'"
+ }
+
+hard :: Gruvbox a -> Gruvbox a
+hard gb = gb { _bg = _bg0h gb }
+
+soft :: Gruvbox a -> Gruvbox a
+soft gb = gb { _bg = _bg0s gb }
+
+gruvboxDark :: Gruvbox SomeColor
+gruvboxDark = SomeColor <$> Gruvbox
+ { _bg = [hex|#282828|]
+ , _red = [hex|#cc241d|]
+ , _green = [hex|#98971a|]
+ , _yellow = [hex|#d79921|]
+ , _blue = [hex|#458588|]
+ , _purple = [hex|b16286|]
+ , _aqua = [hex|689d6a|]
+ , _gray = [hex|a89984|]
+ , _gray' = [hex|928374|]
+ , _red' = [hex|fb4934|]
+ , _green' = [hex|b8bb26|]
+ , _yellow' = [hex|fabd2f|]
+ , _blue' = [hex|83a598|]
+ , _purple' = [hex|d3869b|]
+ , _aqua' = [hex|8ec07c|]
+ , _fg = [hex|ebdbb2|]
+ , _bg0h = [hex|1d2021|]
+ , _bg0 = [hex|282828|]
+ , _bg0s = [hex|32302f|]
+ , _bg1 = [hex|3c3836|]
+ , _bg2 = [hex|504945|]
+ , _bg3 = [hex|665c54|]
+ , _bg4 = [hex|7c6f64|]
+ , _gray'' = [hex|928374|]
+ , _orange = [hex|d65d0e|]
+ , _fg4 = [hex|a89984|]
+ , _fg3 = [hex|bdae93|]
+ , _fg2 = [hex|d5c4a1|]
+ , _fg1 = [hex|ebdbb2|]
+ , _fg0 = [hex|fbf1c7|]
+ , _orange' = [hex|fe8019|]
+ }
+
+gruvboxDarkH :: Gruvbox SomeColor
+gruvboxDarkH = hard gruvboxDark
+
+gruvboxDarkS :: Gruvbox SomeColor
+gruvboxDarkS = soft gruvboxDark
+
+
+gruvboxLight :: Gruvbox SomeColor
+gruvboxLight =
+ let gb = someToAlpha <$> gruvboxDark
+ in SomeColor <$> gb
+ { _bg = [hex|fbf1c7|]
+ , _gray = [hex|7c6f64|]
+ , _red' = [hex|9d0006|]
+ , _green' = [hex|79740e|]
+ , _yellow' = [hex|b57614|]
+ , _blue' = [hex|076678|]
+ , _purple' = [hex|8f3f71|]
+ , _aqua' = [hex|427b58|]
+ , _fg = [hex|3c3836|]
+ , _bg0h = [hex|f9f5d7|]
+ , _bg0 = [hex|fbf1c7|]
+ , _bg0s = [hex|f2e5bc|]
+ , _bg1 = [hex|ebdbb2|]
+ , _bg2 = [hex|d5c4a1|]
+ , _bg3 = [hex|bdae93|]
+ , _bg4 = [hex|a89984|]
+ , _fg4 = [hex|7c6f64|]
+ , _fg3 = [hex|665c54|]
+ , _fg2 = [hex|504945|]
+ , _fg1 = [hex|3c3836|]
+ , _fg0 = [hex|282828|]
+ , orange' = [hex|af3a03|]
+ }
+
+gruvboxLightH :: Gruvbox SomeColor
+gruvboxLightH = hard gruvboxLight
+
+gruvboxLightS :: Gruvbox SomeColor
+gruvboxLightS = soft gruvboxLight
diff --git a/src/WWW/Colors/Hex.hs b/src/WWW/Colors/Hex.hs
new file mode 100644
index 0000000..1773e66
--- /dev/null
+++ b/src/WWW/Colors/Hex.hs
@@ -0,0 +1,34 @@
+{-# LANGUAGE TemplateHaskell #-}
+module WWW.Colors.Hex
+ ( HexColor
+ ) where
+
+import Data.Colour
+import Digrams.Attributes
+import Language.Haskell.TH.Quote
+
+
+newtype HexColor = HexColor ByteString
+ deriving (Eq, Generic, Ord)
+
+instance Bounded HexColor where
+ maxBound = HexColor "\255\255\255"
+ minBound = HexColor "\NUL\NUL\NUL"
+
+
+instance Color HexColor where
+
+
+
+
+hex :: QuasiQuoter
+hex = QuasiQuoter
+ { quoteExp = parseit
+ , quotePat = failure "quotePat"
+ , quoteType = failure "quoteType"
+ , quoteDec = failure "quoteDec"
+ } where
+ failure s = const $ fail $ "No " <> s <> " defined for the hexcolor quasiquoter."
+ parseit s = case undefined of
+ Nothing -> fail $ "Can't understand " <> s <> " as a valid hex color."
+ Just h -> h `seq` [|h|]
diff --git a/src/WWW/Colors/Instances.hs b/src/WWW/Colors/Instances.hs
new file mode 100644
index 0000000..e071b6b
--- /dev/null
+++ b/src/WWW/Colors/Instances.hs
@@ -0,0 +1,23 @@
+module WWW.Colors.Instances where
+
+import Clay.Color qualified as Clay
+import Data.Colour
+import Data.Colour.SRGB (toSRGB24, sRGB24, RGB (..))
+import Diagrams.Attributes
+import GHC.Float (double2Float, float2Double)
+
+
+instance Color Clay.Color where
+ toAlphaColour :: Clay.Color -> AlphaColour Double
+ toAlphaColour col = case Clay.toRgba col of
+ Clay.Rgba r g b a ->
+ let rgb = sRGB24 (fromInteger r) (fromInteger g) (fromInteger b)
+ in withOpacity rgb (float2Double a)
+ _ -> error "Should not happen"
+
+ fromAlphaColour :: AlphaColour Double -> Clay.Color
+ fromAlphaColour col =
+ let c = fromAlphaColour col :: Colour Double
+ a = alphaChannel col
+ rgb = toInteger <$> toSRGB24 c
+ in Clay.rgba (channelRed rgb) (channelGreen rgb) (channelBlue rgb) (double2Float a)
diff --git a/src/WWW/Colors/QQ.hs b/src/WWW/Colors/QQ.hs
new file mode 100644
index 0000000..4a03dbb
--- /dev/null
+++ b/src/WWW/Colors/QQ.hs
@@ -0,0 +1,27 @@
+{-# LANGUAGE TemplateHaskell #-}
+module WWW.Colors.QQ
+ ( hex
+ ) where
+
+-- import Data.Colour
+-- import Data.Colour.SRGB
+import Control.Monad ((>=>))
+import Diagrams.Backend.CmdLine (readHexColor)
+import Language.Haskell.TH.Quote
+
+
+
+-- | QuasiQuoter which reads in a hex color code and ouputs a 'AlphaColour Double'.
+hex :: QuasiQuoter
+hex = QuasiQuoter
+ { quoteExp = readHexColor >=> \x -> x `seq` pure [|x|]
+ , quotePat = failure "quotePat"
+ , quoteType = failure "quoteType"
+ , quoteDec = failure "quoteDec"
+ } where
+ failure s = const $ fail $ "No " <> s <> " defined for the hexcolor quasiquoter."
+ -- readit = sRGB24reads :: ReadS (Colour Double)
+ -- parseit s =
+ -- case readit s of
+ -- [(x,[])] -> x `seq` [|x|]
+ -- _ -> fail $ "Can't understand " <> s <> " as a valid hex color"
generated by cgit v1.2.3 (git 2.25.1) at 2026-07-09 21:57:28 +0000