Added Core.Colors

Define a Palette, handle Colors gracefully, simply interfaced to output
to Clay or String formats.

CHANGELOG.md

@@ -8,4 +8,12 @@ and this project adheres to the
 
 ## Unreleased
 
-## 0.1.0.0 - 2022-09-12
+### Planned utils
+
+* Add svg generation (with diagrams-lib, or diagrams? Investigation needed)
+* Add font subsetting
+* Add images utils such as conversion to png, avif and other formats (see hip)
+
+## 0.1.0.0 - YYYY-MM-DD
+
+* Added colours and palettes support (with colour package back-end)

README.md

@@ -1,9 +1,10 @@
 # My new attempt at a personal site
 
-It uses Hakyll, a Haskell static site compiler, along with other Haskell libs:
+A personal CMS written in Haskell. The most prominent libraries used are
 
-* Shakespeare (Hamlet) to generate html
-* Clay to preprocess css
+* [Hakyll](https://hackage.haskell.org/package/hakyll), a static site compiler.
+* [Shakespeare](https://hackage.haskell.org/package/shakespeare) (Hamlet) to generate html
+* [Clay](https://hackage.haskell.org/package/clay) to preprocess css
 
 ## Building
 

etienne-moqueur.cabal

@@ -17,6 +17,7 @@ extra-source-files:
 
 library
   exposed-modules:
+      Core.Colors
       Core.Compilers
       Core.Render
       Core.Routers
@@ -30,12 +31,15 @@ library
   hs-source-dirs:
       src
   default-extensions:
-      OverloadedStrings QuasiQuotes
+      OverloadedStrings QuasiQuotes FlexibleInstances
   ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints
   build-depends:
-      base >=4.7 && <5
+      ansi-terminal
+    , array
+    , base >=4.7 && <5
     , blaze-html
     , clay
+    , colour
     , hakyll
     , shakespeare
     , text
@@ -48,12 +52,15 @@ executable etienne-moqueur-exe
   hs-source-dirs:
       app
   default-extensions:
-      OverloadedStrings QuasiQuotes
+      OverloadedStrings QuasiQuotes FlexibleInstances
   ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N
   build-depends:
-      base >=4.7 && <5
+      ansi-terminal
+    , array
+    , base >=4.7 && <5
     , blaze-html
     , clay
+    , colour
     , etienne-moqueur
     , hakyll
     , shakespeare
@@ -68,12 +75,15 @@ test-suite etienne-moqueur-test
   hs-source-dirs:
       test
   default-extensions:
-      OverloadedStrings QuasiQuotes
+      OverloadedStrings QuasiQuotes FlexibleInstances
   ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N
   build-depends:
-      base >=4.7 && <5
+      ansi-terminal
+    , array
+    , base >=4.7 && <5
     , blaze-html
     , clay
+    , colour
     , etienne-moqueur
     , hakyll
     , shakespeare

package.yaml

@@ -25,6 +25,9 @@ dependencies:
 - clay
 - text
 - blaze-html
+- array
+- colour
+- ansi-terminal
 
 ghc-options:
 - -Wall
@@ -40,6 +43,7 @@ ghc-options:
 default-extensions:
   OverloadedStrings
   QuasiQuotes
+  FlexibleInstances
 
 library:
   source-dirs: src

src/Core/Colors.hs

@@ -0,0 +1,131 @@
+module Core.Colors
+  ( Ramp
+  , rampC
+  , rampCBy
+  , ramp
+  , rampBy
+  , opacity
+  , Core.Colors.dissolve
+  , blend
+  , Palette(..)
+  ) where
+
+import           Clay.Color                     ( Color
+                                                , rgba
+                                                )
+import           Control.Monad                  ( liftM2 )
+import           Data.Array                    as A
+import           Data.Bifunctor                 ( second )
+import           Data.Char                      ( intToDigit )
+import           Data.Colour
+import           Data.Colour.SRGB
+import           Data.List                      ( sortBy )
+
+-- slope from one colour to the other using a slope function that should be 0 at 0 and 1 at 1 with values in [0..1]
+slopeBy
+  :: (AffineSpace f, Floating a)
+  => (a -> a)
+  -> (Int, f a)
+  -> (Int, f a)
+  -> [(Int, f a)]
+slopeBy f (i, c) (i', c')
+  | i < i'    = [ (j, blend (w i i' j) c c') | j <- [i .. i'] ]
+  | i > i'    = [ (j, blend (w i' i j) c' c) | j <- [i' .. i] ]
+  | otherwise = [(i, c)]
+  where w x y z = f $ fromIntegral (y - z) / fromIntegral (y - x)
+
+---------------------------------------------------------------------------
+
+-- |This type represents a path through a RGBSpace. It is constructed as an 'Array' with 'Int' indices from 0 to 100. Index 0 defaults to an empty colour ('black' or 'transparent'), but this can be overridden.
+newtype Ramp f a = Ramp (Array Int (f a))
+  deriving (Eq, Show, Read)
+
+-- |The non-overloaded version of 'rampC'. The provided function must be defined over [0,1] and be 0 at 1 and 1 at 1.
+rampCBy
+  :: (Monoid (f a), AffineSpace f, Floating a)
+  => (a -> a)
+  -> f a
+  -> [(Int, f a)]
+  -> Ramp f a
+rampCBy f w l = Ramp . array (0, 100) $ concat slopes
+ where
+  slopes = uncurry (slopeBy f) <$> pairs
+  pairs =
+    map (liftM2 (,) head last . take 2)
+      $   map drop [0 .. length l' - 2]
+      <*> pure l'
+  l'         = sortBy (\(a, _) (b, _) -> compare a b) checkRight
+  checkLeft  = if 0 `notElem` ixs then (0, mempty) : l else l
+  checkRight = if 100 `notElem` ixs then (100, w) : checkLeft else checkLeft
+  ixs        = fst <$> l
+
+-- |Make a 'Ramp' by providing control 'Colour's \/ 'AlphaColour's at specified indices, and a default colour for index 100 (usually white).
+rampC
+  :: (Monoid (f a), AffineSpace f, Floating a)
+  => f a
+  -> [(Int, f a)]
+  -> Ramp f a
+rampC = rampCBy id
+
+-- |The non-overloaded version of 'ramp'. The provided function must be defined over [0,1] and be 0 at 0 and 1 at 1.
+rampBy
+  :: (Floating a, Ord a)
+  => (a -> a)
+  -> String
+  -> [(Int, String)]
+  -> Ramp Colour a
+rampBy f s = rampCBy f (sRGB24read s) . fmap (second sRGB24read)
+
+-- |Make a 'Ramp' by providing control 'Colour's in hexadecimal form, e.g. \"#ff0000\". Uses the sRGB space and 'white' as the default 'Colour' for index 100.
+ramp :: (Floating a, Ord a) => [(Int, String)] -> Ramp Colour a
+ramp = rampBy id "#ffffff"
+
+instance AffineSpace f => AffineSpace (Ramp f) where
+  affineCombo l (Ramp z) =
+    Ramp
+      . array (bounds z)
+      $ [ (i, affineCombo (extract i l) (z A.! i)) | i <- indices z ]
+    where extract i = map (\(w, Ramp r) -> (w, r A.! i))
+
+instance ColourOps f => ColourOps (Ramp f) where
+  c `over` Ramp r = Ramp $ over c <$> r
+  darken s (Ramp r) = Ramp $ darken s <$> r
+
+-- |Creates a 'Ramp AlphaColour' from a 'Ramp Colour' with a given opacity.
+opacity :: Num a => a -> Ramp Colour a -> Ramp AlphaColour a
+opacity o (Ramp r) = Core.Colors.dissolve o (Ramp $ opaque <$> r)
+
+-- |Create a 'Ramp' more transparent by a given factor.
+dissolve :: Num a => a -> Ramp AlphaColour a -> Ramp AlphaColour a
+dissolve d (Ramp r) = Ramp $ Data.Colour.dissolve d <$> r
+
+---------------------------------------------------------------------------
+
+-- |The 'Palette' class acts as a front-end for the rest of the code and allows to simply interface 'Ramp's values.
+class Palette p where
+  (!) :: p Float -> Int -> Color
+  (?) :: p Float -> Int -> String
+
+rgbToClay :: RGB Integer -> Float -> Color
+rgbToClay (RGB r g b) = rgba r g b
+
+hex :: Int -> String
+hex w = intToDigit <$> [quot w 16, rem w 16]
+
+instance Palette (Ramp Colour) where
+  (Ramp a) ! i = rgbToClay (toInteger <$> toSRGB24 (a A.! i)) 1
+  (Ramp r) ? i = sRGB24show $ r A.! i
+
+instance Palette (Ramp AlphaColour) where
+  (Ramp a) ! i = rgbToClay (toInteger <$> toSRGB24 c) alpha
+   where
+    c        = alphaCol `over` black
+    alpha    = alphaChannel alphaCol
+    alphaCol = a A.! i
+  (Ramp a) ? i = sRGB24show c ++ alphaCode
+   where
+    c         = alphaCol `over` black
+    alphaCode = hex . floor . (* 255) . alphaChannel $ alphaCol
+    alphaCol  = a A.! i
+
+---------------------------------------------------------------------------

src/Core/Compilers.hs

@@ -6,7 +6,8 @@ import           Hakyll
 
 -- Redundant... Those default extensions should be kept in sync with package.yaml, but `stack runghc` won't take those in account.
 defaultExtensions :: [String]
-defaultExtensions = ["--", "-XQuasiQuotes", "-XOverloadedStrings"]
+defaultExtensions =
+  ["--", "-XQuasiQuotes", "-XOverloadedStrings", "-XFlexibleInstances"]
 
 runGHC :: Compiler (Item String)
 runGHC = getResourceString

src/Kit/Templates/Post.hs

@@ -1,8 +1,8 @@
 module Kit.Templates.Post (postHamlet, main) where
 
-import           Core.Render
-import           Routes
-import           Text.Hamlet
+import Core.Render (renderHamlet)
+import Routes
+import Text.Hamlet (HtmlUrl, hamlet)
 
 postHamlet :: HtmlUrl Route
 postHamlet = [hamlet|