From 097acc6e5d470b3f3651a65475808274932c7e48 Mon Sep 17 00:00:00 2001
From: Adrian Cochrane <adrian@openwork.nz>
Date: Wed, 22 Dec 2021 14:52:09 +1300
Subject: [PATCH] Display CSS styles in web UI.

---
 assets/pantheon.css |  6 ++++++
 src/Main.hs         | 13 +++++++++++-
 src/UI/Templates.hs | 48 ++++++++++++++++++++++++++++++++++++++++++++-
 3 files changed, 65 insertions(+), 2 deletions(-)

diff --git a/assets/pantheon.css b/assets/pantheon.css
index a2d4a7e..18faa80 100644
--- a/assets/pantheon.css
+++ b/assets/pantheon.css
@@ -47,6 +47,8 @@ blockquote { /* Only being used for code..., though appropriate I'm quoting that
 .tok-ident {color: #dc322f; voice-stress: strong;}
 .tok-string {color: #859900; voice-pitch: high;}
 .tok-comment {color: #839496; voice-volume: soft;}
+.tok-error {color: red; voice-stress: x-strong;}
+.tok-num {color: #d33682; voice-pitch: low;}
 
 @media (prefers-color-scheme: dark) {
     body {
@@ -64,3 +66,7 @@ blockquote { /* Only being used for code..., though appropriate I'm quoting that
 dl > dt {font-weight: bold; text-align: center;}
 dl > dd {margin: 0;}
 .disclosure {float: right}
+
+dl.tabular {display: grid}
+dl.tabular > dt {grid-column: 1}
+dl.tabular > dd {grid-column: 2}
diff --git a/src/Main.hs b/src/Main.hs
index 63cc388..2738ff4 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -29,6 +29,8 @@ import Internal
 import Internal.Load as Load
 import Internal.Elements as El
 import Internal.Forms as Forms
+import Internal.Style as Style
+import Data.CSS.Syntax.Tokens as Style
 import Control.Monad.IO.Class (liftIO)
 import Control.Monad (forM)
 
@@ -204,7 +206,16 @@ serveEl' uuid session session' el = do
     let title = toStrict $ renderMarkup $ contents $ Tpl.xmlNode' $ XC.node el
     related <- liftIO $ getRelatedEls session el
     elValue <- liftIO $ Forms.readInput' session el
-    Tpl.inspector ok title session' $ Tpl.elPage uuid el related elValue
+    let styles = M.toList $ Style.styleCursor session' el
+    Tpl.inspector ok title session' $ \langs -> do
+        Tpl.elPage uuid el related elValue langs
+        H.aside $ H.dl H.! A.class_ "tabular" $ do
+            forM styles $ \(prop, val) -> do
+                H.dt $ do
+                    Tpl.identTok $ Txt.pack prop
+                    Tpl.symbolTok False ":"
+                H.dd $ Tpl.hlCSSs val
+            return ()
 
 serveElPreview uuid session el = do
     nullDir
diff --git a/src/UI/Templates.hs b/src/UI/Templates.hs
index fd519e4..ef9f639 100644
--- a/src/UI/Templates.hs
+++ b/src/UI/Templates.hs
@@ -1,6 +1,6 @@
 {-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}
 module UI.Templates(page, inspector, inspector', sessionForm,
-    xmlNode, xmlNode', elSelector, elPage) where
+    xmlNode, xmlNode', elSelector, elPage, hlCSS, hlCSSs, identTok, symbolTok) where
 
 import Happstack.Lite
 import Text.Blaze.Html5 as H
@@ -21,6 +21,8 @@ import Text.XML.Cursor as XC
 import qualified Data.Map as M
 import Data.Maybe (fromMaybe)
 
+import Data.CSS.Syntax.Tokens
+
 import Messages
 import Happstack.Server.I18N
 
@@ -160,6 +162,50 @@ qualifyTok = token "qualify"
 keywordTok = token "keyword"
 identTok = token "ident"
 stringTok = token "string" . pack
+stringTok' = token "string"
 commentTok = token "comment"
+errorTok = token "error"
+numTok = token "num"
 
 token type_ txt = H.span ! class_ (stringValue ("tok-" ++ type_)) $ text txt
+
+--- CSS formatting
+hlCSSs toks = do
+    forM toks $ \tok -> do
+        hlCSS tok
+        text " " -- Because Haskell Stylist stripes Whitespace out from properties.
+    return ()
+hlCSS Whitespace = " " -- Filtered out by caller.
+hlCSS CDO = commentTok "<!--"
+hlCSS CDC = commentTok "-->"
+hlCSS Comma = symbolTok True ","
+hlCSS Colon = symbolTok True ":"
+hlCSS Semicolon = symbolTok True ";"
+hlCSS LeftParen = "("
+hlCSS RightParen = ")"
+hlCSS LeftSquareBracket = "["
+hlCSS RightSquareBracket = "]"
+hlCSS LeftCurlyBracket = "{"
+hlCSS RightCurlyBracket = "}"
+hlCSS SuffixMatch = symbolTok True "$="
+hlCSS SubstringMatch = symbolTok True "*="
+hlCSS PrefixMatch = symbolTok True "^="
+hlCSS DashMatch = symbolTok True "|="
+hlCSS IncludeMatch = symbolTok True "~="
+hlCSS Column = symbolTok True "||"
+hlCSS tok@(String _) = stringTok' $ serialize [tok]
+hlCSS BadString = errorTok "\"\n"
+hlCSS (Number x _) = numTok x
+hlCSS (Percentage x _) = numTok (x `Txt.append` "%")
+hlCSS (Dimension x _ u) = numTok (x `Txt.append` u)
+hlCSS (Url x) = do
+    identTok "url("
+    stringTok' x
+    text ")"
+hlCSS BadUrl = errorTok "url(()"
+hlCSS (Ident x) = keywordTok x
+hlCSS (AtKeyword x) = keywordTok ('@' `Txt.cons` x)
+hlCSS (Function x) = identTok (x `Txt.append` "(")
+hlCSS (Hash HId x) = keywordTok ('#' `Txt.cons` x)
+hlCSS (Hash HUnrestricted x) = stringTok' ('#' `Txt.cons` x)
+hlCSS (Delim x) = symbolTok True $ Txt.pack [x]
-- 
2.30.2