Theme switching

src/Yoga/Block/Atom/Input/View/Container.purs

@@ -10,33 +10,33 @@ import React.Basic.DOM (CSS, css)
 import React.Basic.Emotion (Style)
 import Yoga.Block.Atom.Input.Style as Style
 
-type PropsF f
-  = ( css ∷ f Style
-    , isInvalid ∷ f Boolean
-    | Style.Props f (MandatoryProps ())
-    )
+type PropsF f =
+  ( css ∷ f Style
+  , isInvalid ∷ f Boolean
+  | Style.Props f (MandatoryProps ())
+  )
 
-type MandatoryProps r
-  = ( children ∷ Array JSX
-    , hasFocus ∷ Boolean
-    | r
-    )
+type MandatoryProps r =
+  ( children ∷ Array JSX
+  , hasFocus ∷ Boolean
+  | r
+  )
 
-type Props
-  = PropsF Id
+type Props =
+  PropsF Id
 
-type PropsOptional
-  = PropsF OptionalProp
+type PropsOptional =
+  PropsF OptionalProp
 
 component ∷ ∀ p q. Union p q Props => ReactComponent { | MandatoryProps p }
 component = rawContainer
 
-type Propski
-  = { css ∷ OptionalProp Style
-    , hasFocus ∷ Boolean
-    , isInvalid ∷ OptionalProp Boolean
-    , children ∷ Array JSX
-    }
+type Propski =
+  { css ∷ OptionalProp Style
+  , hasFocus ∷ Boolean
+  , isInvalid ∷ OptionalProp Boolean
+  , children ∷ Array JSX
+  }
 
 rawContainer ∷ ∀ p. ReactComponent { | p }
 rawContainer =
@@ -52,11 +52,11 @@ rawContainer =
                 { className: "ry-input-container"
                 , css: Style.inputContainer props
                 , _data:
-                    props.isInvalid
-                      # foldMap \isInvalid ->
-                          Object.fromHomogeneous
-                            { "invalid": show isInvalid
-                            }
+                  props.isInvalid
+                    # foldMap \isInvalid ->
+                        Object.fromHomogeneous
+                          { "invalid": show isInvalid
+                          }
                 , ref
                 }
             /> props.children
@@ -66,11 +66,8 @@ drawPathUntil ∷ Int -> Array Point -> String
 drawPathUntil idx thePath = do
   let
     fn { x, y } = i x "%" " " y "%"
-  let
     firstFew = Array.take idx thePath
-  let
     lastFew = Array.drop idx thePath $> (Array.last firstFew # fromMaybe' \_ -> unsafeCrashWith "ogod")
-  let
     rendered = intercalate "," $ fn <$> (firstFew <> lastFew)
   i "polygon(" rendered ")"
 
@@ -87,7 +84,6 @@ mkPath borderX borderY = do
       , {- ⌝ -} p (100 - borderX) borderY
       , {- ⌜ -} p borderX borderY
       ]
-
     outside =
       [ {-⌜    -} p 0 0
       , {-⌞    -} p 0 100
@@ -118,18 +114,18 @@ containerVariants ∷
   }
 containerVariants =
   { focussed:
-      css
-        { clipPath
-        , transition: { duration: 0.6 }
-        }
+    css
+      { clipPath
+      , transition: { duration: 0.6 }
+      }
   , blurred:
-      css
-        { clipPath:
-            drawPathUntil (Array.length path + 1) path
-        }
+    css
+      { clipPath:
+        drawPathUntil (Array.length path + 1) path
+      }
   }
   where
   clipPath = 6 Array... (Array.length path) <#> \ln -> drawPathUntil ln path
 
-type Point
-  = { x ∷ Int, y ∷ Int }
+type Point =
+  { x ∷ Int, y ∷ Int }

src/Yoga/Block/Container/Style.js

@@ -1,2 +1,6 @@
 exports.getComputedStyleImpl = (el, window) => window.getComputedStyle(el)
-exports.getPropertyValueImpl = (propName, computedStyle) => computedStyle.getPropertyValue(propName)
+exports.getPropertyValueImpl = (propName, computedStyle) => computedStyle.getPropertyValue(propName)
+exports.getElementStyle = el => () => el.style
+exports.setStyleProperty = prop => value => style => () => style.setProperty(prop, value)
+exports.matchMedia = string => window => () => window.matchMedia(string)
+exports.matches = matchMedia => () => matchMedia.matches

src/Yoga/Block/Container/Style.purs

@@ -10,6 +10,7 @@ import Heterogeneous.Mapping (class HMapWithIndex, class MappingWithIndex, hmap,
 import Unsafe.Coerce (unsafeCoerce)
 import Web.DOM (Element)
 import Web.DOM.Document (documentElement)
+import Web.Event.Internal.Types (EventTarget)
 import Web.HTML (Window, window)
 import Web.HTML.HTMLDocument as HTMLDocument
 import Web.HTML.Window (document)
@@ -47,13 +48,33 @@ foreign import getPropertyValueImpl ∷ EffectFn2 String ComputedStyle String --
 getPropertyValue ∷ String -> ComputedStyle -> Effect String
 getPropertyValue = runEffectFn2 getPropertyValueImpl
 
+foreign import data ElementStyle ∷ Type
+
+foreign import getElementStyle ∷ Element -> Effect ElementStyle
+
+foreign import setStyleProperty ∷ String -> String -> ElementStyle -> Effect Unit
+
+foreign import data MediaQueryList ∷ Type
+
+foreign import matchMedia ∷ String -> Window -> Effect MediaQueryList
+
+foreign import matches ∷ MediaQueryList -> Effect Boolean
+
+toEventTarget ∷ MediaQueryList -> EventTarget
+toEventTarget = unsafeCoerce
+
+getDocumentElement ∷ MaybeT Effect Element
+getDocumentElement = do
+  win <- window # lift
+  htmlDoc <- document win # lift
+  let doc = HTMLDocument.toDocument htmlDoc
+  documentElement doc # MaybeT
+
 getDarkOrLightMode ∷ Effect (Maybe DarkOrLightMode)
 getDarkOrLightMode =
   runMaybeT do
     win <- window # lift
-    htmlDoc <- document win # lift
-    let doc = HTMLDocument.toDocument htmlDoc
-    docElem ∷ Element <- documentElement doc # MaybeT
+    docElem ∷ Element <- getDocumentElement
     computedStyle <- getComputedStyle docElem win # lift
     pv <- getPropertyValue "--theme-variant" computedStyle # lift
     if pv == "dark" then
@@ -64,6 +85,17 @@ getDarkOrLightMode =
       else
         Nothing # pure # MaybeT
 
+setDarkOrLightMode ∷ DarkOrLightMode -> Effect Unit
+setDarkOrLightMode desiredMode =
+  runMaybeT_ do
+    docElem <- getDocumentElement
+    style <- getElementStyle docElem # lift
+    style
+      # setStyleProperty "--theme-variant" case desiredMode of
+          LightMode -> "light"
+          DarkMode -> "dark"
+      # lift
+
 mkGlobal ∷ Maybe DarkOrLightMode -> Style
 mkGlobal maybeMode =
   css

src/Yoga/Block/Container/View.purs

@@ -8,13 +8,18 @@ import Effect.Unsafe (unsafePerformEffect)
 import React.Basic.DOM as R
 import React.Basic.Emotion as E
 import React.Basic.Hooks (reactComponent)
+import React.Basic.Hooks as React
 import Unsafe.Coerce (unsafeCoerce)
-import Yoga.Block.Container.Style (DarkOrLightMode)
+import Web.Event.EventTarget (addEventListener, eventListener, removeEventListener)
+import Web.HTML (window)
+import Web.HTML.Event.EventTypes as Event
+import Yoga.Block.Container.Style (DarkOrLightMode(..), matchMedia, matches, setDarkOrLightMode)
 import Yoga.Block.Container.Style as Styles
 
 type PropsF f =
   ( content ∷ JSX
   , themeVariant ∷ f (Maybe DarkOrLightMode)
+  , onPreferredSystemThemeChange ∷ f (DarkOrLightMode -> Effect Unit)
   )
 
 type Props =
@@ -23,20 +28,62 @@ type Props =
 component ∷ ∀ p q. Union p q Props => ReactComponent { | p }
 component = rawComponent
 
+mkPrefersDark ∷ Effect Styles.MediaQueryList
+mkPrefersDark = matchMedia "(prefers-color-scheme: dark)" =<< window
+
+mkPrefersLight ∷ Effect Styles.MediaQueryList
+mkPrefersLight = matchMedia "(prefers-color-scheme: light)" =<< window
+
 rawComponent ∷ ∀ p. ReactComponent { | p }
 rawComponent =
   unsafeCoerce
     $ unsafePerformEffect
-    $ reactComponent "Container" \({ content, themeVariant } ∷ { | PropsF OptionalProp }) -> React.do
+    $ reactComponent "Container" \(props@{ content } ∷ { | PropsF OptionalProp }) -> React.do
+        let propsThemeVariant = props.themeVariant # opToMaybe # join
+        let notifySystemThemeChanged = props.onPreferredSystemThemeChange ?|| mempty
+        systemThemeVariant /\ setSystemThemeVariant <- React.useState' Nothing
+        useEffect propsThemeVariant do
+          for_ propsThemeVariant setDarkOrLightMode
+          mempty
+        useEffectOnce do
+          prefersDarkMediaQuery <- mkPrefersDark
+          prefersLightMediaQuery <- mkPrefersLight
+          -- Init system preference
+          whenM (matches prefersDarkMediaQuery) do
+            setSystemThemeVariant (Just DarkMode)
+            notifySystemThemeChanged DarkMode
+          whenM (matches prefersLightMediaQuery) do
+            setSystemThemeVariant (Just LightMode)
+            notifySystemThemeChanged LightMode
+          -- Dark Mode listener
+          darkModeListener <-
+            eventListener \_ -> do
+              whenM (matches prefersDarkMediaQuery) do
+                setSystemThemeVariant (Just DarkMode)
+                notifySystemThemeChanged DarkMode
+          addEventListener Event.change darkModeListener true (Styles.toEventTarget prefersDarkMediaQuery)
+          -- Light Mode listener
+          lightModeListener <-
+            eventListener \_ -> do
+              whenM (matches prefersLightMediaQuery) do
+                setSystemThemeVariant (Just LightMode)
+                notifySystemThemeChanged LightMode
+          addEventListener Event.change darkModeListener true (Styles.toEventTarget prefersDarkMediaQuery)
+          addEventListener Event.change lightModeListener true (Styles.toEventTarget prefersLightMediaQuery)
+          pure do
+            removeEventListener Event.change darkModeListener true (Styles.toEventTarget prefersDarkMediaQuery)
+            removeEventListener Event.change lightModeListener true (Styles.toEventTarget prefersLightMediaQuery)
         pure
           $ R.div_
           $ Array.cons
               ( element E.global
                   { styles:
-                    case opToMaybe themeVariant # join of
-                      Nothing -> Styles.global
-                      Just Styles.DarkMode -> Styles.darkMode
-                      Just Styles.LightMode -> Styles.lightMode
+                    case propsThemeVariant, systemThemeVariant of
+                      Nothing, Nothing -> Styles.global
+                      Just Styles.DarkMode, _ -> Styles.darkMode
+                      Just Styles.LightMode, _ -> Styles.lightMode
+                      Nothing, Just DarkMode -> Styles.darkMode
+                      Nothing, Just LightMode -> Styles.lightMode
                   }
               )
               [ content