diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/WWW/Colors.hs | 106 | ||||
| -rw-r--r-- | src/WWW/Colors/Instances.hs | 6 | ||||
| -rw-r--r-- | src/WWW/Colors/QQ.hs | 2 | ||||
| -rw-r--r-- | src/WWW/Css.hs | 10 | ||||
| -rw-r--r-- | src/WWW/Logos/Abacus.hs | 1 |
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 |