Trying to write css

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
+--         "--