css themes wip

Author: functora

cabal.project

@@ -51,6 +51,7 @@ else
                  reanimate-svg:*,
                  tdlib:*,
                  secp256k1-haskell,
+                 ghc,
     packages:
       pub/hs-bitcoin-hash/bitcoin-hash/*.cabal
       pub/hs-bitcoin-keys/bitcoin-keys/*.cabal

ghcjs/delivery-calculator/src/App/Types.hs

@@ -41,6 +41,7 @@ import qualified Data.Generics as Syb
 import qualified Data.Version as Version
 import Functora.Cfg
 import Functora.Miso.Prelude
+import qualified Functora.Miso.Theme as Theme
 import Functora.Miso.Types as X hiding
   ( newFieldPair,
     newFieldPairId,
@@ -90,7 +91,8 @@ data St f = St
     stOnlineOrOffline :: OnlineOrOffline,
     stFavName :: Field Unicode f,
     stPreview :: Field Unicode f,
-    stScreen :: Screen
+    stScreen :: Screen,
+    stTheme :: Theme
   }
   deriving stock (Generic)
 
@@ -130,7 +132,8 @@ newSt = do
         stOnlineOrOffline = Online,
         stFavName = fav,
         stPreview = pre & #fieldType .~ FieldTypeTitle,
-        stScreen = Main
+        stScreen = Main,
+        stTheme = Theme.Paper
       }
 
 data Asset f = Asset

ghcjs/delivery-calculator/src/App/Widgets/Menu.hs

@@ -274,6 +274,18 @@ menu st =
                     & #optsLabel
                     .~ Just ("QR title" :: Unicode)
                 )
+              <> [ Select.select
+                    ( Select.defOpts
+                        & #optsLabel
+                        .~ Just "Theme"
+                    )
+                    Select.Args
+                      { Select.argsModel = st,
+                        Select.argsOptic = #modelState . #stTheme,
+                        Select.argsAction = PushUpdate . Instant,
+                        Select.argsOptions = constTraversal $ enumerate @Theme
+                      }
+                 ]
         }
 
 qrButton :: Model -> View Action

ghcjs/delivery-calculator/src/Main.hs

@@ -84,8 +84,10 @@ runApp app = do
   where
     router js req =
       case Wai.pathInfo req of
-        ("static" : _) ->
-          staticApp (defaultWebAppSettings ".") req
+        ("static" : "css" : path) ->
+          staticApp
+            (defaultWebAppSettings "../miso-functora/dist/css")
+            req {Wai.pathInfo = path}
         ("node_modules" : _) ->
           staticApp (defaultWebAppSettings ".") req
         ("favicon.ico" : _) ->
@@ -242,18 +244,16 @@ viewModel st =
         [ rel_ "stylesheet",
           href_ "static/css/fontawesome.min.css"
         ],
+      -- href_ "https://unpkg.com/[email protected]/css/nes.min.css"
+      -- href_ "node_modules/@lowlighter/matcha/dist/matcha.css"
+      -- href_ "https://unpkg.com/@sakun/system.css"
+      -- href_ "https://unpkg.com/papercss/dist/paper.min.css"
+      -- href_ "https://unpkg.com/[email protected]/dist/terminal.min.css"
+      -- href_ "https://vinibiavatti1.github.io/TuiCss/dist/tuicss.min.css"
+      -- href_ "https://fieber.hack.re/fieber.css"
       link_
         [ rel_ "stylesheet",
-          -- href_ "https://unpkg.com/[email protected]/css/nes.min.css"
-          -- href_ "static/css/mvp.css"
-          -- href_ "static/css/simple.min.css"
-          -- href_ "static/css/tacit-css-1.8.1.min.css"
-          -- href_ "node_modules/@lowlighter/matcha/dist/matcha.css"
-          -- href_ "https://unpkg.com/@sakun/system.css"
-          -- href_ "https://unpkg.com/papercss/dist/paper.min.css"
-          -- href_ "https://unpkg.com/[email protected]/dist/terminal.min.css"
-          -- href_ "https://vinibiavatti1.github.io/TuiCss/dist/tuicss.min.css"
-          href_ "https://fieber.hack.re/fieber.css"
+          href_ $ "static/css/" <> themeCssFile (st ^. #modelState . #stTheme)
         ],
       link_
         [ rel_ "stylesheet",

ghcjs/miso-functora/Setup.hs

@@ -17,6 +17,11 @@
 {-# OPTIONS_GHC -Wno-safe #-}
 {-# OPTIONS_GHC -Wno-unsafe #-}
 {-# OPTIONS_GHC -fprint-potential-instances #-}
+#if MIN_VERSION_ghc(9,0,0)
+{-# OPTIONS_GHC -Wno-missing-kind-signatures #-}
+{-# OPTIONS_GHC -Wno-prepositive-qualified-module #-}
+{-# OPTIONS_GHC -Wno-missing-safe-haskell-mode #-}
+#endif
 
 import qualified Data.Text as T
 import Distribution.Simple hiding (Module (..))
@@ -77,10 +82,12 @@ codeGenHook _ = do
           sort . fmap (dropEnd 8) $ filter (isSuffixOf ".min.css") cssRaw
     let cssPascal =
           fmap Casing.pascal cssKebab
-    when (cssKebab /= fmap Casing.kebab cssPascal)
-      . error
-      $ "Bad kebab <-> pascal isomorphism in "
-      <> inspect @Text cssKebab
+    if cssKebab == fmap Casing.kebab cssPascal
+      then putStrLn $ inspect @Text cssPascal
+      else
+        error
+          $ "Bad kebab <-> pascal isomorphism in "
+          <> inspect @Text cssKebab
     liftIO
       . writeFileIfChanged
       . showPpr dflags
@@ -98,6 +105,7 @@ generateCode prog css =
               import'
               [ "Prelude",
                 "Data.Data",
+                "Data.Binary",
                 "GHC.Generics"
               ]
           )
@@ -118,7 +126,8 @@ generateCode prog css =
                       "Enum",
                       "Bounded"
                     ]
-              ]
+              ],
+            instance' (var "Binary" @@ var "Theme") mempty
           ]
     }
   where

ghcjs/miso-functora/miso-functora.cabal

@@ -19,7 +19,7 @@ custom-setup
     , functora-ghcjs
     , ghc
     , ghc-paths
-    , ghc-source-gen  ==0.4.2.0
+    , ghc-source-gen
     , text
 
 common pkg
@@ -85,6 +85,7 @@ common pkg
   build-depends:
     , barbies
     , base
+    , binary
     , bytestring
     , casing
     , functora-ghcjs
@@ -127,6 +128,7 @@ library
     Functora.Miso.Jsm.Specific
     Functora.Miso.Orphan
     Functora.Miso.Prelude
+    Functora.Miso.Theme
     Functora.Miso.Types
     Functora.Miso.Widgets.BrowserLink
     Functora.Miso.Widgets.Currency

ghcjs/miso-functora/src/Functora/Miso/Theme.hs

@@ -4,6 +4,7 @@ module Functora.Miso.Theme (
     ) where
 import Prelude
 import Data.Data
+import Data.Binary
 import GHC.Generics
 data Theme
   = A11yana |
@@ -139,4 +140,5 @@ data Theme
     Wing |
     Writ |
     Yorha
-  deriving stock (Eq, Ord, Show, Read, Data, Generic, Enum, Bounded)
+  deriving stock (Eq, Ord, Show, Read, Data, Generic, Enum, Bounded)
+instance Binary Theme

ghcjs/miso-functora/src/Functora/Miso/Types.hs

@@ -50,7 +50,9 @@ module Functora.Miso.Types
     LeadingOrTrailing (..),
     OpenedOrClosed (..),
     Update (..),
+    themeCssFile,
     evalUpdate,
+    module X,
   )
 where
 
@@ -59,8 +61,10 @@ import Data.Functor.Barbie
 import qualified Data.Generics as Syb
 import Functora.Cfg
 import Functora.Miso.Prelude
+import Functora.Miso.Theme as X (Theme)
 import Functora.Money hiding (Currency, Money)
 import qualified Miso.Html.Types as Miso
+import qualified Text.Casing as Casing
 import qualified Text.URI as URI
 
 type Typ a =
@@ -542,6 +546,13 @@ data Update model
   | PureAndEffectUpdate (model -> model) (JSM ())
   deriving stock (Generic)
 
+themeCssFile :: Theme -> Unicode
+themeCssFile =
+  (<> ".min.css")
+    . from @String @Unicode
+    . Casing.kebab
+    . inspect @String
+
 evalUpdate :: model -> Update model -> JSM model
 evalUpdate x = \case
   PureUpdate f -> pure $ f x