summaryrefslogtreecommitdiff
path: root/src/WWW
diff options
context:
space:
mode:
Diffstat (limited to 'src/WWW')
-rw-r--r--src/WWW/Colors.hs106
-rw-r--r--src/WWW/Colors/Instances.hs6
-rw-r--r--src/WWW/Colors/QQ.hs2
-rw-r--r--src/WWW/Css.hs10
-rw-r--r--src/WWW/Logos/Abacus.hs1
5 files changed, 91 insertions, 34 deletions
diff --git a/src/WWW/Colors.hs b/src/WWW/Colors.hs
index a266414..eff09f4 100644
--- a/src/WWW/Colors.hs
+++ b/src/WWW/Colors.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE QuasiQuotes #-}
module WWW.Colors
( Gruvbox (..)
@@ -22,39 +23,82 @@ 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)
+instance Applicative Gruvbox where
+ pure a = Gruvbox a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a
+ {-# INLINE pure #-}
+ (<*>) :: Gruvbox (a -> b) -> Gruvbox a -> Gruvbox b
+ g <*> x = Gruvbox
+ { _bg = ag _bg g x
+ , _red = ag _red g x
+ , _green = ag _green g x
+ , _yellow = ag _yellow g x
+ , _blue = ag _blue g x
+ , _purple = ag _purple g x
+ , _aqua = ag _aqua g x
+ , _gray = ag _gray g x
+ , _gray' = ag _gray' g x
+ , _red' = ag _red' g x
+ , _green' = ag _green' g x
+ , _yellow' = ag _yellow' g x
+ , _blue' = ag _blue' g x
+ , _purple' = ag _purple' g x
+ , _aqua' = ag _aqua' g x
+ , _fg = ag _fg g x
+ , _bg0h = ag _bg0h g x
+ , _bg0 = ag _bg0 g x
+ , _bg0s = ag _bg0s g x
+ , _bg1 = ag _bg1 g x
+ , _bg2 = ag _bg2 g x
+ , _bg3 = ag _bg3 g x
+ , _bg4 = ag _bg4 g x
+ , _gray'' = ag _gray'' g x
+ , _orange = ag _orange g x
+ , _fg4 = ag _fg4 g x
+ , _fg3 = ag _fg3 g x
+ , _fg2 = ag _fg2 g x
+ , _fg1 = ag _fg1 g x
+ , _fg0 = ag _fg0 g x
+ , _orange' = ag _orange g x
+ }
+ {-# INLINE (<*>) #-}
+
+ag :: (forall x . Gruvbox x -> x) -> Gruvbox (a -> b) -> Gruvbox a -> b
+ag f g x = f g $ f x
+{-# INLINE ag #-}
+
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'"
+ { _bg = "bg"
+ , _red = "red"
+ , _green = "green"
+ , _yellow = "yellow"
+ , _blue = "blue"
+ , _purple = "purple"
+ , _aqua = "aqua"
+ , _gray = "gray"
+ , _gray' = "gray'"
+ , _red' = "red'"
+ , _green' = "green'"
+ , _yellow' = "yellow'"
+ , _blue' = "blue'"
+ , _purple' = "purple'"
+ , _aqua' = "aqua'"
+ , _fg = "fg"
+ , _bg0h = "bg0h"
+ , _bg0 = "bg0"
+ , _bg0s = "bg0s"
+ , _bg1 = "bg1"
+ , _bg2 = "bg2"
+ , _bg3 = "bg3"
+ , _bg4 = "bg4"
+ , _gray'' = "gray''"
+ , _orange = "orange"
+ , _fg4 = "fg4"
+ , _fg3 = "fg3"
+ , _fg2 = "fg2"
+ , _fg1 = "fg1"
+ , _fg0 = "fg0"
+ , _orange' = "orange'"
}
hard :: Gruvbox a -> Gruvbox a
diff --git a/src/WWW/Colors/Instances.hs b/src/WWW/Colors/Instances.hs
index 3fc7667..3dd6e6a 100644
--- a/src/WWW/Colors/Instances.hs
+++ b/src/WWW/Colors/Instances.hs
@@ -2,6 +2,7 @@
module WWW.Colors.Instances where
import Clay.Color qualified as Clay
+import Clay.Property qualified as Clay
import Data.Colour
import Data.Colour.SRGB (toSRGB24, sRGB24, RGB (..))
import Diagrams.Attributes
@@ -13,7 +14,7 @@ instance Color Clay.Color where
toAlphaColour col = case Clay.toRgba col of
Clay.Rgba r g b a ->
let rgb = sRGB24 (fromInteger r) (fromInteger g) (fromInteger b)
- in alphaColourConvert $ withOpacity rgb a
+ in alphaColourConvert $ rgb `withOpacity` a
_ -> error "Should not happen"
fromAlphaColour :: AlphaColour Double -> Clay.Color
@@ -21,3 +22,6 @@ instance Color Clay.Color where
let a = alphaChannel $ alphaColourConvert col
RGB r g b = toInteger <$> toSRGB24 (fromAlphaColour @(Colour Double) col)
in Clay.rgba r g b a
+
+instance Clay.Val SomeColor where
+ value = Clay.value . fromAlphaColour @Clay.Color . someToAlpha
diff --git a/src/WWW/Colors/QQ.hs b/src/WWW/Colors/QQ.hs
index 281a93a..f1dc256 100644
--- a/src/WWW/Colors/QQ.hs
+++ b/src/WWW/Colors/QQ.hs
@@ -20,7 +20,7 @@ data Color' = Color' !Double !Double !Double !Double
deriving Lift
instance Color Color' where
- toAlphaColour (Color' r g b a) = withOpacity (sRGB r g b) a
+ toAlphaColour (Color' r g b a) = sRGB r g b `withOpacity` a
fromAlphaColour col =
let a = alphaChannel col
RGB r g b = toSRGB $ fromAlphaColour @(Colour Double) col
diff --git a/src/WWW/Css.hs b/src/WWW/Css.hs
index 164b2af..05aec62 100644
--- a/src/WWW/Css.hs
+++ b/src/WWW/Css.hs
@@ -3,6 +3,8 @@ module WWW.Css where
import Control.Monad
import Clay
import Clay.Flexbox qualified as F
+import Clay.Stylesheet
+import Data.Foldable (fold)
import Data.Text (Text)
import Diagrams.Attributes (SomeColor)
@@ -12,7 +14,13 @@ import WWW.Colors qualified as G
colorVariables :: G.Gruvbox SomeColor -> Css
colorVariables gb = do
- "--html-bg" -: "test"
+ fold $ key <$> (("--" <>) <$> G.gruvboxVar) <*> gb
+ key "--html-bg" $ G._bg1 gb
+ key "--href" $ G._orange gb
+ key "--href-hover" $ G._orange' gb
+ key "--hr" $ G._gray gb
+ key "--code-bg" $ G._bg gb
+
rootColors :: Css
rootColors = do
diff --git a/src/WWW/Logos/Abacus.hs b/src/WWW/Logos/Abacus.hs
new file mode 100644
index 0000000..81653f6
--- /dev/null
+++ b/src/WWW/Logos/Abacus.hs
@@ -0,0 +1 @@
+module WWW.Logos.Abacus where
generated by cgit v1.2.3 (git 2.25.1) at 2026-07-09 20:17:36 +0000