Add a HasCss class

This way I can attach page-specific CSS to the type for the page. I could make
this even tighter by combining HasCss with the HTML declaration, but that would
basically just be Lucid.ToHtml, so I'm not sure it is worth it.

1 files changed, 223 insertions, 218 deletions

diff --git a/Biz/Devalloc.hs b/Biz/Devalloc.hs
index bc1b83f..ce70f07 100644
--- a/Biz/Devalloc.hs
+++ b/Biz/Devalloc.hs
@@ -56,7 +56,7 @@ module Biz.Devalloc
 where
 
 import Alpha hiding (rem, (<.>))
-import Biz.App (CSS (..), HtmlApp (..))
+import qualified Biz.App as App
 import qualified Biz.Cli as Cli
 import qualified Biz.Id as Id
 import qualified Biz.Log as Log
@@ -629,9 +629,9 @@ instance Envy.FromEnv OAuthArgs
 -- * paths and pages
 
 -- | Wraps pages in default HTML
-instance Lucid.ToHtml a => Lucid.ToHtml (HtmlApp a) where
+instance (Lucid.ToHtml a, App.HasCss a) => Lucid.ToHtml (App.Html a) where
   toHtmlRaw = Lucid.toHtml
-  toHtml (HtmlApp x) =
+  toHtml (App.Html x) =
     Lucid.doctypehtml_ <| do
       Lucid.head_ <| do
         Lucid.title_ "Devalloc.io :: Know your codebase, know your team."
@@ -645,9 +645,13 @@ instance Lucid.ToHtml a => Lucid.ToHtml (HtmlApp a) where
           ]
         Lucid.meta_ [Lucid.charset_ "utf-8"]
         jsRef "//unpkg.com/turbolinks@5.2.0/dist/turbolinks.js"
-        cssRef "/css/main.css"
+        -- base styles
+        style baseStyle
+        -- page styles
+        style <| App.cssFor x
       Lucid.body_ (Lucid.toHtml x)
     where
+      style = Lucid.style_ <. toStrict <. Clay.renderWith Clay.compact []
       jsRef _href =
         Lucid.with
           (Lucid.script_ mempty)
@@ -655,19 +659,12 @@ instance Lucid.ToHtml a => Lucid.ToHtml (HtmlApp a) where
             Lucid.makeAttribute "async" mempty,
             Lucid.makeAttribute "defer" mempty
           ]
-      cssRef _href =
-        Lucid.with
-          (Lucid.link_ mempty)
-          [ Lucid.rel_ "stylesheet",
-            Lucid.type_ "text/css",
-            Lucid.href_ _href
-          ]
 
 -- | All of the routes in the app.
 data Paths path = Paths
   { home ::
       path
-        :- Get '[Lucid.HTML] (HtmlApp Home),
+        :- Get '[Lucid.HTML] (App.Html Home),
     login ::
       path
         :- "login"
@@ -678,46 +675,41 @@ data Paths path = Paths
         :> "github"
         :> "callback"
         :> QueryParam "code" Text
-        :> Get '[Lucid.HTML] (SetCookies (HtmlApp UserAccount)),
+        :> Get '[Lucid.HTML] (SetCookies (App.Html UserAccount)),
     getAccount ::
       path
         :- Auth.Auth '[Auth.Cookie] User
         :> "account"
-        :> Get '[Lucid.HTML] (HtmlApp UserAccount),
+        :> Get '[Lucid.HTML] (App.Html UserAccount),
     postAccount ::
       path
         :- Auth.Auth '[Auth.Cookie] User
         :> "account"
         :> ReqBody '[FormUrlEncoded] Subscription
-        :> Post '[Lucid.HTML] (HtmlApp UserAccount),
+        :> Post '[Lucid.HTML] (App.Html UserAccount),
     selectRepo ::
       path
         :- Auth.Auth '[Auth.Cookie] User
         :> "select-repo"
-        :> Get '[Lucid.HTML] (HtmlApp SelectRepo),
+        :> Get '[Lucid.HTML] (App.Html SelectRepo),
     getAnalyses ::
       path
         :- Auth.Auth '[Auth.Cookie] User
         :> "analysis"
-        :> Get '[Lucid.HTML] (HtmlApp Analyses),
+        :> Get '[Lucid.HTML] (App.Html Analyses),
     getAnalysis ::
       path
         :- Auth.Auth '[Auth.Cookie] User
         :> "analysis"
         :> Capture "analysisId" (Id.Id Analysis)
-        :> Get '[Lucid.HTML] (HtmlApp AnalysisDisplay),
+        :> Get '[Lucid.HTML] (App.Html AnalysisDisplay),
     postAnalysis ::
       path
         :- Auth.Auth '[Auth.Cookie] User
         :> "analysis"
         :> QueryParam "user" Text
         :> QueryParam "repo" Text
-        :> Post '[Lucid.HTML] (HtmlApp AnalysisDisplay),
-    css ::
-      path
-        :- "css"
-        :> "main.css"
-        :> Get '[CSS] Text
+        :> Post '[Lucid.HTML] (App.Html AnalysisDisplay)
   }
   deriving (Generic)
 
@@ -771,7 +763,7 @@ htmlApp cooks kp cfg jwk oAuthArgs =
           |> Acid.query' kp
           /> head
           /> Home oAuthArgs
-          /> HtmlApp,
+          /> App.Html,
       login =
         pure <| addHeader (githubLoginUrl oAuthArgs) NoContent,
       githubAuth = \case
@@ -800,18 +792,18 @@ htmlApp cooks kp cfg jwk oAuthArgs =
               -- I think this should redirect to instead of rendering UserAccount
               Just applyCookies ->
                 UserAccount user
-                  |> HtmlApp
+                  |> App.Html
                   |> applyCookies
                   |> pure,
       getAccount =
-        guardAuth >=> UserAccount .> HtmlApp .> pure,
+        guardAuth >=> UserAccount .> App.Html .> pure,
       postAccount = \a subscription ->
         guardAuth a
           +> \user ->
             UpdateUser user {userSubscription = subscription}
               |> Acid.update' kp
               +> UserAccount
-              .> HtmlApp
+              .> App.Html
               .> pure,
       selectRepo =
         guardAuth
@@ -822,14 +814,14 @@ htmlApp cooks kp cfg jwk oAuthArgs =
               |> liftIO
               +> \case
                 Left err -> throwError err502 {errBody = show err}
-                Right repos -> pure <. HtmlApp <| SelectRepo user repos,
+                Right repos -> pure <. App.Html <| SelectRepo user repos,
       getAnalyses =
         guardAuth
           >=> \user@User {..} ->
             GetAnalysesByAsker user
               |> Acid.query' kp
               +> Analyses user
-              .> HtmlApp
+              .> App.Html
               .> pure,
       getAnalysis = \a analysisId ->
         guardAuth a
@@ -838,7 +830,7 @@ htmlApp cooks kp cfg jwk oAuthArgs =
               |> Acid.query' kp
               +> \case
                 Nothing -> throwError err404
-                Just analysis -> pure <| HtmlApp <| AnalysisDisplay user analysis,
+                Just analysis -> pure <| App.Html <| AnalysisDisplay user analysis,
       postAnalysis = \a mOwner mRepo ->
         guardAuth a
           +> \user@User {..} -> do
@@ -854,197 +846,155 @@ htmlApp cooks kp cfg jwk oAuthArgs =
               repo
               |> liftIO
               +> AnalysisDisplay user
-              .> HtmlApp
-              .> pure,
-      css =
-        pure <. toStrict <. Clay.render <| do
-          let yellow = "#ffe000"
-          let black = "#121212"
-          Biz.Look.fuckingStyle
-
-          Biz.Look.whenDark <| do
-            "body" ? do
-              Clay.backgroundColor black
-            "a:link" <> "a:visited" ? do
-              Clay.textDecorationColor Clay.white
-              Clay.color Clay.white
-            "a:hover" ? do
-              Clay.textDecorationColor yellow
-            "select" <> "button" <> "input" ? do
-              Clay.backgroundColor black
-              Clay.color Clay.white
-
-          Biz.Look.whenLight <| do
-            "body" ? do
-              Clay.color black
-            "a:link" <> "a:visited" ? do
-              Clay.textDecorationColor black
-              Clay.color black
-            "a:hover" ? do
-              Clay.textDecorationColor yellow
-            "select" <> "button" <> "input" ? do
-              Clay.backgroundColor Clay.white
-              Clay.color black
-
-          "body" ? Biz.Look.fontStack
-          "header" ? do
-            Clay.maxWidth (pct 100)
-          "footer" ? do
-            Clay.fontStyle Clay.italic
-            Clay.fontSize (rem 0.8)
-            Clay.marginTop (em 6)
-            Clay.marginBottom (em 6)
-          "a" ? do
-            Clay.transition "all" (sec 0.2) Clay.ease 0
-            Clay.transitionProperties
-              [ "text-decoration-color",
-                "text-decoration-thickness",
-                "text-decoration-width"
-              ]
-            Clay.textDecoration Clay.underline
-            Biz.Look.textDecorationThickness (em 0.1)
-            Biz.Look.textDecorationWidth (em 0.1)
-          "a:hover" ? do
-            Clay.textDecorationColor yellow
-            Clay.textDecoration Clay.underline
-            Biz.Look.textDecorationThickness (em 0.2)
-            Biz.Look.textDecorationWidth (em 0.2)
-
-          "select" <> "button" <> "input" ? do
-            Biz.Look.paddingAll (em 0.5)
-            Biz.Look.marginX (em 0.5)
-            Clay.borderColor yellow
-            Clay.borderStyle Clay.solid
-
-          -- for making POST requests with a form disguised as a link
-          "input.link" ? do
-            Clay.borderWidth 0
-            Clay.fontSize (rem 1)
-            Biz.Look.marginAll (px 0)
-            Biz.Look.paddingAll (px 0)
-
-          "label" ? do
-            Clay.display Clay.inlineBlock
-            Clay.width (px 100)
-
-          "nav" ? do
-            Clay.display Clay.flex
-            Clay.justifyContent Clay.spaceBetween
-            "a" ? do
-              Clay.padding (em 1) (em 1) (em 1) (em 1)
-              Clay.display Clay.block
-            "ul" ? do
-              Clay.display Clay.flex
-              Clay.justifyContent Clay.flexEnd
-              Clay.listStyleType Clay.none
-              Clay.margin (Clay.px 0) 0 0 0
-              "li" ? do
-                Clay.padding 0 (px 5) 0 (px 5)
-
-          "details" ? do
-            Clay.display Clay.inline
-            "summary" ? do
-              Clay.color "#6c757d"
-              Clay.display Clay.listItem
-              Clay.cursor Clay.pointer
-          "#home" ? do
-            "p" ? Clay.textAlign Clay.center
-            "h1" ? do
-              Clay.fontSize (Clay.rem 3)
-            "h1" <> "h2" ? do
-              Clay.textAlign Clay.center
-            ".example" ? do
-              Clay.borderStyle Clay.solid
-              Clay.borderWidth (px 2)
-              Clay.borderColor "#aaa"
-              Biz.Look.borderRadiusAll (px 10)
-              Biz.Look.paddingX (em 2)
-              Biz.Look.paddingY (em 1)
-            "section" ? do
-              Clay.padding (rem 3) 0 (rem 3) 0
-            "a#try-button" <> "a#try-button:visited" ? do
-              Clay.transition "all" (sec 0.2) Clay.ease 0
-              Clay.transitionProperties
-                ["color", "background-color", "border-color"]
-              Clay.padding (em 0.5) (em 1) (em 0.5) (em 1)
-              Clay.display Clay.flex
-              Clay.flexDirection Clay.column
-              Clay.margin (em 3) Clay.auto 0 Clay.auto
-              Clay.width (px 250)
-              Clay.borderWidth (px 1)
-              Clay.borderStyle Clay.solid
-              Clay.borderColor black
-              Clay.backgroundColor yellow
-              Clay.color black
-              Clay.textDecoration Clay.none
-              Clay.justifyContent Clay.center
-              Clay.alignItems Clay.center
-              Clay.fontWeight Clay.bold
-              "small" ? do
-                Clay.fontSize (px 10)
-            "a#try-button:hover" ? do
-              Clay.borderColor yellow
-              Clay.color yellow
-              Clay.backgroundColor black
-
-          "#analysis" ? do
-            Clay.display Clay.grid
-            Clay.justifyContent Clay.spaceAround
-            Biz.Look.rowGap (rem 2)
-            Biz.Look.marginY (rem 1)
-            Biz.Look.gridTemplateAreas
-              [ "analysisFor",
-                "metrics"
-              ]
-
-            ".metrics" ? do
-              Clay.gridTemplateColumns [pct 50, pct 50]
-              Clay.display Clay.grid
-              Biz.Look.columnGap (em 2)
-              Biz.Look.rowGap (em 2)
-            ".score" ? do
-              Clay.display Clay.flex
-              Clay.flexDirection Clay.column
-              ".title" ? do
-                Clay.fontSize (rem 1.4)
-                Clay.lineHeight (rem 2.4)
-              ".percentage" ? do
-                Clay.display Clay.flex
-                Clay.alignItems Clay.baseline
-                ".centum" ? do
-                  Clay.fontSize (rem 1.2)
-                  Clay.lineHeight (rem 1.2)
-              ".quantity" ? do
-                Clay.fontSize (rem 3)
-                Clay.lineHeight (rem 3)
-              "details" ? do
-                Biz.Look.gridArea "details-collapsed"
-              "details[open]" ? do
-                Biz.Look.gridArea "details"
-
-          "#selectRepo" ? do
-            "ul" ? do
-              Clay.listStyleType Clay.none
-              Clay.margin (px 0) 0 0 0
-              Clay.padding (px 0) 0 0 0
-              "li" ? do
-                Clay.borderBottomWidth (px 1)
-                Clay.borderBottomColor "#999"
-                Clay.borderBottomStyle Clay.solid
-                Clay.padding (em 1.5) 0 (em 1.5) 0
-                ".link" ? do
-                  Clay.fontSize (em 1.17)
+              .> App.Html
+              .> pure
     }
 
+baseStyle :: Clay.Css
+baseStyle = do
+  Biz.Look.fuckingStyle
+
+  Biz.Look.whenDark <| do
+    "body" ? do
+      Clay.backgroundColor black
+    "a:link" <> "a:visited" ? do
+      Clay.textDecorationColor Clay.white
+      Clay.color Clay.white
+    "a:hover" ? do
+      Clay.textDecorationColor yellow
+    "select" <> "button" <> "input" ? do
+      Clay.backgroundColor black
+      Clay.color Clay.white
+
+  Biz.Look.whenLight <| do
+    "body" ? do
+      Clay.color black
+    "a:link" <> "a:visited" ? do
+      Clay.textDecorationColor black
+      Clay.color black
+    "a:hover" ? do
+      Clay.textDecorationColor yellow
+    "select" <> "button" <> "input" ? do
+      Clay.backgroundColor Clay.white
+      Clay.color black
+
+  "body" ? Biz.Look.fontStack
+  "header" ? do
+    Clay.maxWidth (pct 100)
+  "footer" ? do
+    Clay.fontStyle Clay.italic
+    Clay.fontSize (rem 0.8)
+    Clay.marginTop (em 6)
+    Clay.marginBottom (em 6)
+  "a" <> "input.link" ? do
+    Clay.transition "all" (sec 0.2) Clay.ease 0
+    Clay.transitionProperties
+      [ "text-decoration-color",
+        "text-decoration-thickness",
+        "text-decoration-width"
+      ]
+    Clay.textDecoration Clay.underline
+    Biz.Look.textDecorationThickness (em 0.1)
+    Biz.Look.textDecorationWidth (em 0.1)
+  "a:hover" <> "input.link" ? do
+    Clay.textDecorationColor yellow
+    Clay.textDecoration Clay.underline
+    Biz.Look.textDecorationThickness (em 0.2)
+    Biz.Look.textDecorationWidth (em 0.2)
+
+  "select" <> "button" <> "input" ? do
+    Biz.Look.paddingAll (em 0.5)
+    Biz.Look.marginX (em 0.5)
+    Clay.borderColor yellow
+    Clay.borderStyle Clay.solid
+
+  -- for making POST requests with a form disguised as a link
+  "input.link" ? do
+    Clay.cursor Clay.pointer
+    Clay.borderWidth 0
+    Clay.fontSize (rem 1)
+    Biz.Look.marginAll (px 0)
+    Biz.Look.paddingAll (px 0)
+
+  "label" ? do
+    Clay.display Clay.inlineBlock
+    Clay.width (px 100)
+
+  "nav" ? do
+    Clay.display Clay.flex
+    Clay.justifyContent Clay.spaceBetween
+    "a" ? do
+      Clay.padding (em 1) (em 1) (em 1) (em 1)
+      Clay.display Clay.block
+    "ul" ? do
+      Clay.display Clay.flex
+      Clay.justifyContent Clay.flexEnd
+      Clay.listStyleType Clay.none
+      Clay.margin (Clay.px 0) 0 0 0
+      "li" ? do
+        Clay.padding 0 (px 5) 0 (px 5)
+
+  "details" ? do
+    Clay.display Clay.inline
+    "summary" ? do
+      Clay.color "#6c757d"
+      Clay.display Clay.listItem
+      Clay.cursor Clay.pointer
+
+yellow, black :: Clay.Color
+yellow = "#ffe000"
+black = "#121212"
+
 -- | The front page pitch. Eventually I'd like to load the content from markdown
 -- files or some other store of data so I can A/B test.
 data Home = Home OAuthArgs (Maybe Analysis)
 
+instance App.HasCss Home where
+  cssFor (Home _ _) = do
+    "p" ? Clay.textAlign Clay.center
+    "h1" ? do
+      Clay.fontSize (Clay.rem 3)
+    "h1" <> "h2" ? do
+      Clay.textAlign Clay.center
+    ".example" ? do
+      Clay.borderStyle Clay.solid
+      Clay.borderWidth (px 2)
+      Clay.borderColor "#aaa"
+      Biz.Look.borderRadiusAll (px 10)
+      Biz.Look.paddingX (em 2)
+      Biz.Look.paddingY (em 1)
+    "section" ? do
+      Clay.padding (rem 3) 0 (rem 3) 0
+    "a#try-button" <> "a#try-button:visited" ? do
+      Clay.transition "all" (sec 0.2) Clay.ease 0
+      Clay.transitionProperties
+        ["color", "background-color", "border-color"]
+      Clay.padding (em 0.5) (em 1) (em 0.5) (em 1)
+      Clay.display Clay.flex
+      Clay.flexDirection Clay.column
+      Clay.margin (em 3) Clay.auto 0 Clay.auto
+      Clay.width (px 250)
+      Clay.borderWidth (px 1)
+      Clay.borderStyle Clay.solid
+      Clay.borderColor black
+      Clay.backgroundColor yellow
+      Clay.color black
+      Clay.textDecoration Clay.none
+      Clay.justifyContent Clay.center
+      Clay.alignItems Clay.center
+      Clay.fontWeight Clay.bold
+      "small" ? do
+        Clay.fontSize (px 10)
+    "a#try-button:hover" ? do
+      Clay.borderColor yellow
+      Clay.color yellow
+      Clay.backgroundColor black
+
 instance Lucid.ToHtml Home where
   toHtmlRaw = Lucid.toHtml
   toHtml (Home oAuthArgs analysis) = do
     header Nothing
-    Lucid.main_ [Lucid.id_ "home"] <| do
+    Lucid.main_ <| do
       section <| do
         h1 "Know your codebase."
         h1 "Know your team."
@@ -1098,6 +1048,9 @@ instance Lucid.ToHtml Home where
 
 data Analyses = Analyses User [Analysis]
 
+instance App.HasCss Analyses where
+  cssFor _ = mempty
+
 instance Lucid.ToHtml Analyses where
   toHtmlRaw = Lucid.toHtml
   toHtml (Analyses user@User {..} analyses) = do
@@ -1113,12 +1066,12 @@ instance Lucid.ToHtml Analyses where
           forM_ analyses <| \Analysis {..} ->
             Lucid.a_
               [ href analysisId,
-                style <| Biz.Look.marginAll (em 1)
+                css <| Biz.Look.marginAll (em 1)
                   <> Clay.textDecoration Clay.none
               ]
               <| do
                 Lucid.div_ <| Lucid.toHtml url
-                Lucid.div_ [style <| Clay.fontSizeCustom Clay.Font.small]
+                Lucid.div_ [css <| Clay.fontSizeCustom Clay.Font.small]
                   <| Lucid.toHtml commit
     footer
     where
@@ -1126,6 +1079,9 @@ instance Lucid.ToHtml Analyses where
 
 newtype UserAccount = UserAccount User
 
+instance App.HasCss UserAccount where
+  cssFor (UserAccount _) = mempty
+
 instance Lucid.ToHtml Subscription where
   toHtmlRaw = Lucid.toHtml
   toHtml Free = "Free"
@@ -1163,8 +1119,8 @@ instance Lucid.ToHtml UserAccount where
           then [Lucid.selected_ <| tshow sel]
           else mempty
 
-style :: Clay.Css -> Lucid.Attribute
-style = Lucid.style_ <. toStrict <. Clay.renderWith Clay.htmlInline []
+css :: Clay.Css -> Lucid.Attribute
+css = Lucid.style_ <. toStrict <. Clay.renderWith Clay.htmlInline []
 
 -- | A type for parsing JSON auth responses, used in 'githubOauth' below.
 -- Should be moved to Biz.Auth with others.
@@ -1218,11 +1174,25 @@ githubLoginUrl OAuthArgs {..} =
 -- | This view presents a list of repos to select for analysis.
 data SelectRepo = SelectRepo User (Vector GitHub.Repo)
 
+instance App.HasCss SelectRepo where
+  cssFor (SelectRepo _ _) = do
+    "ul" ? do
+      Clay.listStyleType Clay.none
+      Clay.margin (px 0) 0 0 0
+      Clay.padding (px 0) 0 0 0
+      "li" ? do
+        Clay.borderBottomWidth (px 1)
+        Clay.borderBottomColor "#999"
+        Clay.borderBottomStyle Clay.solid
+        Clay.padding (em 1.5) 0 (em 1.5) 0
+        ".link" ? do
+          Clay.fontSize (em 1.17)
+
 instance Lucid.ToHtml SelectRepo where
   toHtmlRaw = Lucid.toHtml
   toHtml (SelectRepo user repos) = do
     header <| Just user
-    Lucid.main_ [Lucid.id_ "selectRepo"] <| do
+    Lucid.main_ <| do
       Lucid.h2_ "Select a repo to analyze"
       Lucid.ul_ <| Lucid.toHtml <| traverse_ displayRepo (Vector.toList repos)
     footer
@@ -1294,6 +1264,41 @@ footer =
 -- web page, hence this type.
 data AnalysisDisplay = AnalysisDisplay User Analysis
 
+instance App.HasCss AnalysisDisplay where
+  cssFor (AnalysisDisplay _ _) = do
+    Clay.display Clay.grid
+    Clay.justifyContent Clay.spaceAround
+    Biz.Look.rowGap (rem 2)
+    Biz.Look.marginY (rem 1)
+    Biz.Look.gridTemplateAreas
+      [ "analysisFor",
+        "metrics"
+      ]
+    ".metrics" ? do
+      Clay.gridTemplateColumns [pct 50, pct 50]
+      Clay.display Clay.grid
+      Biz.Look.columnGap (em 2)
+      Biz.Look.rowGap (em 2)
+    ".score" ? do
+      Clay.display Clay.flex
+      Clay.flexDirection Clay.column
+      ".title" ? do
+        Clay.fontSize (rem 1.4)
+        Clay.lineHeight (rem 2.4)
+      ".percentage" ? do
+        Clay.display Clay.flex
+        Clay.alignItems Clay.baseline
+        ".centum" ? do
+          Clay.fontSize (rem 1.2)
+          Clay.lineHeight (rem 1.2)
+      ".quantity" ? do
+        Clay.fontSize (rem 3)
+        Clay.lineHeight (rem 3)
+      "details" ? do
+        Biz.Look.gridArea "details-collapsed"
+      "details[open]" ? do
+        Biz.Look.gridArea "details"
+
 instance Lucid.ToHtml AnalysisDisplay where
   toHtmlRaw = Lucid.toHtml
   toHtml (AnalysisDisplay user anal) = do
@@ -1306,7 +1311,7 @@ instance Lucid.ToHtml AnalysisDisplay where
 instance Lucid.ToHtml Analysis where
   toHtmlRaw = Lucid.toHtml
   toHtml Analysis {..} =
-    Lucid.div_ [Lucid.id_ "analysis"] <| do
+    Lucid.div_ <| do
       Lucid.p_ [Lucid.class_ ".analysisFor"] <| do
         "Analysis for "
         Lucid.a_ [Lucid.href_ <| (\(URL txt) -> txt) <| url] <| do