diff options
Diffstat (limited to 'src/WWW')
| -rw-r--r-- | src/WWW/Colors.hs | 6 | ||||
| -rw-r--r-- | src/WWW/Colors/Hex.hs | 34 | ||||
| -rw-r--r-- | src/WWW/Colors/Instances.hs | 12 | ||||
| -rw-r--r-- | src/WWW/Colors/QQ.hs | 31 | ||||
| -rw-r--r-- | src/WWW/Css.hs | 108 |
5 files changed, 144 insertions, 47 deletions
diff --git a/src/WWW/Colors.hs b/src/WWW/Colors.hs index b52aea7..a266414 100644 --- a/src/WWW/Colors.hs +++ b/src/WWW/Colors.hs @@ -10,7 +10,7 @@ module WWW.Colors , gruvboxLightS ) where -import Data.Colour +-- import Data.Colour import Data.String import Diagrams.Attributes @@ -107,7 +107,7 @@ gruvboxDarkS = soft gruvboxDark gruvboxLight :: Gruvbox SomeColor gruvboxLight = - let gb = someToAlpha <$> gruvboxDark + let gb = someToColor' <$> gruvboxDark in SomeColor <$> gb { _bg = [hex|fbf1c7|] , _gray = [hex|7c6f64|] @@ -130,7 +130,7 @@ gruvboxLight = , _fg2 = [hex|504945|] , _fg1 = [hex|3c3836|] , _fg0 = [hex|282828|] - , orange' = [hex|af3a03|] + , _orange' = [hex|af3a03|] } gruvboxLightH :: Gruvbox SomeColor diff --git a/src/WWW/Colors/Hex.hs b/src/WWW/Colors/Hex.hs deleted file mode 100644 index 1773e66..0000000 --- a/src/WWW/Colors/Hex.hs +++ /dev/null @@ -1,34 +0,0 @@ -{-# 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 index e071b6b..3fc7667 100644 --- a/src/WWW/Colors/Instances.hs +++ b/src/WWW/Colors/Instances.hs @@ -1,23 +1,23 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} 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) +-- | Not perfect, but good enough for building what I need 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) + in alphaColourConvert $ withOpacity rgb 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) + let a = alphaChannel $ alphaColourConvert col + RGB r g b = toInteger <$> toSRGB24 (fromAlphaColour @(Colour Double) col) + in Clay.rgba r g b a diff --git a/src/WWW/Colors/QQ.hs b/src/WWW/Colors/QQ.hs index 4a03dbb..281a93a 100644 --- a/src/WWW/Colors/QQ.hs +++ b/src/WWW/Colors/QQ.hs @@ -1,20 +1,43 @@ {-# LANGUAGE TemplateHaskell #-} module WWW.Colors.QQ ( hex + , Color' + , toColor' + , someToColor' ) where --- import Data.Colour --- import Data.Colour.SRGB +import Data.Colour +import Data.Colour.SRGB import Control.Monad ((>=>)) +import Diagrams.Attributes import Diagrams.Backend.CmdLine (readHexColor) +import Language.Haskell.TH.Syntax import Language.Haskell.TH.Quote +-- | data type defined so we can use template haskell to get compile-time hex colors +data Color' = Color' !Double !Double !Double !Double + deriving Lift --- | QuasiQuoter which reads in a hex color code and ouputs a 'AlphaColour Double'. +instance Color Color' where + toAlphaColour (Color' r g b a) = withOpacity (sRGB r g b) a + fromAlphaColour col = + let a = alphaChannel col + RGB r g b = toSRGB $ fromAlphaColour @(Colour Double) col + in Color' r g b a + + +toColor' :: AlphaColour Double -> Color' +toColor' = fromAlphaColour + +someToColor' :: SomeColor -> Color' +someToColor' = toColor' . someToAlpha + + +-- | QuasiQuoter which reads in a hex color code and outputs a 'AlphaColour Double'. hex :: QuasiQuoter hex = QuasiQuoter - { quoteExp = readHexColor >=> \x -> x `seq` pure [|x|] + { quoteExp = readHexColor >=> pure . toColor' >=> \x -> x `seq` [|x|] , quotePat = failure "quotePat" , quoteType = failure "quoteType" , quoteDec = failure "quoteDec" diff --git a/src/WWW/Css.hs b/src/WWW/Css.hs new file mode 100644 index 0000000..164b2af --- /dev/null +++ b/src/WWW/Css.hs @@ -0,0 +1,108 @@ +module WWW.Css where + +import Control.Monad +import Clay +import Clay.Flexbox qualified as F +import Data.Text (Text) +import Diagrams.Attributes (SomeColor) + +import WWW.Colors qualified as G + + + +colorVariables :: G.Gruvbox SomeColor -> Css +colorVariables gb = do + "--html-bg" -: "test" + +rootColors :: Css +rootColors = do + ":root[color-mode=light]" ? do + colorVariables G.gruvboxLightH + ":root[color-mode=dark]" ? do + colorVariables G.gruvboxDarkH + +general :: Css +general = do + html ? do + fontFamily [ "Fira Sans" ] [ sansSerif ] + backgroundColor $ cvar "html-bg" + color $ cvar "fg" + margin (em 1) auto auto auto + body ? do + backgroundColor $ cvar "bg" + join4 margin auto + maxWidth (cm 30) + border (px 1) solid $ cvar "fg" + join4 padding $ em 1 + a ? do + color $ cvar "href" + textDecoration underline + hover & do + color $ cvar "href-hover" + header ? do + padding nil nil nil nil + margin nil nil nil nil + fontSize $ em 1 + fontWeight bold + textDecoration none + footer ? do + clear both + paddingTop $ px 10 + paddingBottom $ px 15 + fontWeight bold + hr ? do + borderTop (px 3) double $ cvar "hr" + borderBottomWidth 0 + a ? do + textDecoration none + color $ cvar "footer-href" + a # hover ? do + textDecoration underline + color $ cvar "footer-href-hover" + code ? do + fontFamily [ "Fira Code" ] [ monospace ] + backgroundColor $ cvar "code-bg" + join4 padding $ px 2 + + +someClasses :: Css +someClasses = do + ".pull-left" ? do + float floatLeft + ".pull-right" ? do + float floatRight + +menu :: Css +menu = do + clear both + display block + "width" -: "100%" + margin 0 0 (em 1) 0 + color $ cvar "bg" + backgroundColor $ cvar "fg" + "overflow" -: "hidden" + a ? do + display block + float floatLeft + padding (px 5) (px 10) (px 5) (px 10) + color $ cvar "bg" + a # hover ? do + color $ cvar "href-hover" + + + + +-- helpers + +join3 :: Monad m => m (m (m a)) -> m a +join3 = join . join + +join4 :: Monad m => m (m (m (m a))) -> m a +join4 = join . join3 + +cvar :: Text -> Color +cvar n = Other $ value $ "var(--" <> n <> ")" +-- root :: Css +-- root = do +-- ":root" ? do +-- "-- |