From b77ee3947051b9a42496c8cd6bf40bdb5b55b135 Mon Sep 17 00:00:00 2001
From: Adrian Cochrane <adrian@openwork.nz>
Date: Tue, 12 Sep 2023 14:52:24 +1200
Subject: [PATCH] Render <select> elements to multi-column menus.

---
 src/Text/HTML/Form.hs               | 17 ++++++++----
 src/Text/HTML/Form/Query.hs         | 23 ++++++++++++---
 src/Text/HTML/Form/WebApp.hs        | 35 ++++++++++++++++++-----
 src/Text/HTML/Form/WebApp/Ginger.hs | 43 +++++++++++++++++++----------
 tpl/base.html                       | 23 ++++++++++++---
 5 files changed, 106 insertions(+), 35 deletions(-)

diff --git a/src/Text/HTML/Form.hs b/src/Text/HTML/Form.hs
index 4eb0bd2..54ea053 100644
--- a/src/Text/HTML/Form.hs
+++ b/src/Text/HTML/Form.hs
@@ -128,7 +128,7 @@ parseElement el | _:_ <- laxElement "form" el = Just Form {
     | otherwise = Nothing
 
 root :: Axis
-root = singleton . last . ancestor
+root = singleton . last . orSelf ancestor
 laxElements :: [Text] -> Axis
 laxElements ns = checkName (\x -> or [
     on (==) Txt.toCaseFold n $ nameLocalName x | n <- ns])
@@ -222,7 +222,7 @@ parseInput el | _:_ <- laxElement "input" el = Just Input {
                 _ -> Just False) "soft"
         },
 
-        checked = True,
+        checked = False,
         multiple = False,
         formAction = Nothing,
         formEnctype = Nothing,
@@ -279,7 +279,8 @@ parseInput el | _:_ <- laxElement "input" el = Just Input {
     }
     | _:_ <- laxElement "select" el = Just Input {
         inputType = "<select>",
-        label = fromMaybe (attr "name" el "") $ fmap text label',
+        label = fromMaybe (attr "name" el "") $ fmap Txt.concat $
+            fmap filterSelect label',
         description = fromMaybe (mkEl $ attr "title" el "") $ fmap node $
             elByID $ attr "aria-describedby" el "",
 
@@ -295,7 +296,7 @@ parseInput el | _:_ <- laxElement "input" el = Just Input {
 
         dirname = "",
         value = "", -- Sourced from list...
-        checked = True,
+        checked = False,
         readonly = False,
         formAction = Nothing,
         formEnctype = Nothing,
@@ -311,19 +312,21 @@ parseInput el | _:_ <- laxElement "input" el = Just Input {
         fileData = defaultFileData,
         imageData = defaultImageData,
         textArea = defaultTextArea
-    }
+      }
     | otherwise = Nothing
   where
     elByAttr k v = listToMaybe $ (root >=> descendant >=> attributeIs k v) el
     elByID = elByAttr "id"
     label' = elByAttr "for" (attr "id" el "") `orElse`
             listToMaybe $ (ancestor >=> laxElement "label") el
+    filterSelect = descendant >=>
+        checkNot (orSelf ancestor >=> laxElement "select") >=>
+        content
 parseOptions :: Cursor -> [OptionGroup]
 parseOptions el = [parseGroup opt
     | opt <- (descendant >=> laxElements ["option", "optgroup"] >=>
         checkNot (parent >=> laxElement "optgroup")) el]
   where
-    checkNot test = check (not . bool . test)
     parseGroup opt
         | _:_ <- laxElement "option" opt =
             OptGroup "" False [parseOption opt False]
@@ -350,6 +353,8 @@ parseDocument doc n
     forms = orSelf descendant >=> laxElement "form"
     doc' = fromDocument doc
 
+checkNot :: Boolean b => (Cursor -> b) -> Axis
+checkNot test = check (not . bool . test)
 rightToMaybe :: Either a b -> Maybe b
 rightToMaybe (Left _)  = Nothing
 rightToMaybe (Right x) = Just x
diff --git a/src/Text/HTML/Form/Query.hs b/src/Text/HTML/Form/Query.hs
index 11d1e55..3bfcb62 100644
--- a/src/Text/HTML/Form/Query.hs
+++ b/src/Text/HTML/Form/Query.hs
@@ -1,19 +1,34 @@
+{-# LANGUAGE OverloadedStrings #-}
 module Text.HTML.Form.Query(
     renderQueryString, renderQueryString', renderQuery') where
 
-import Text.HTML.Form (Form(..), Input(..))
+import Text.HTML.Form (Form(..), Input(..), OptionGroup(..), Option(..))
 import Network.URI (escapeURIString, isUnescapedInURIComponent)
 import Data.List (intercalate)
 import Data.Text (unpack)
 
 renderQueryString :: Form -> String
 renderQueryString = renderQueryString' . renderQuery'
+renderQueryString' :: [(String, String)] -> String
 renderQueryString' query = intercalate "&" [
-    escape key ++ '=':escape value | (key, value) <- query
+    escape key ++ '=':escape val | (key, val) <- query
   ]
 
 renderQuery' :: Form -> [(String, String)]
-renderQuery' form = [(unpack $ inputName input, unpack $ value input)
-    | input <- inputs form, checked input]
+renderQuery' form = concatMap renderInput' $ inputs form
+renderInput' :: Input -> [(String, String)]
+renderInput' Input { checked = False, inputType = inputType' }
+    | inputType' `elem` ["radio", "checkbox"] = []
+renderInput' Input { inputType = "<select>",
+        inputName = k, value = "", list = opts, multiple = False
+    } | val:_ <- [optValue opt | grp <- opts, opt <- subopts grp, optSelected opt]
+        = [(unpack k, unpack val)]
+      | otherwise = []
+renderInput' Input { inputType = "<select>",
+        inputName = k, list = opts, multiple = True
+    } = [(unpack k, unpack $ optValue opt) |
+            grp <- opts, opt <- subopts grp, optSelected opt]
+renderInput' Input { inputName = k, value = v } = [(unpack k, unpack v)]
 
+escape :: String -> String
 escape = escapeURIString isUnescapedInURIComponent
diff --git a/src/Text/HTML/Form/WebApp.hs b/src/Text/HTML/Form/WebApp.hs
index 986bca7..687facd 100644
--- a/src/Text/HTML/Form/WebApp.hs
+++ b/src/Text/HTML/Form/WebApp.hs
@@ -5,6 +5,7 @@ import Data.ByteString as BS
 import Data.Text as Txt
 import Data.Text.Encoding as Txt
 import Text.Read (readMaybe)
+import Network.URI (unEscapeString)
 
 import Text.HTML.Form (Form(..), Input(..))
 import Text.HTML.Form.WebApp.Ginger (template)
@@ -15,24 +16,44 @@ renderPage form (n:path) query
     | Just ix <- readMaybe $ Txt.unpack n, ix < Prelude.length (inputs form) =
         renderInput form ix (inputs form !! ix) path query
 renderPage form [] _ = return $ Just $ Txt.concat [
-    "<a href='/0?", Txt.pack $ renderQueryString form, "'>Start!</a>"]
+    "<a href='/0?", Txt.pack $ renderQueryString form, "/'>Start!</a>"]
 renderPage _ _ _ = return Nothing
 
 renderInput :: Form -> Int -> Input -> [Text] -> [(ByteString, Maybe ByteString)] ->
     IO (Maybe Text)
+renderInput form ix input [""] qs = renderInput form ix input [] qs
+renderInput form ix input@Input { multiple = True } [p] qs
+    | '=':v' <- Txt.unpack p,
+            (utf8 $ inputName input, Just $ utf8' v') `Prelude.elem` qs =
+        renderInput form ix input [] $
+            unset (inputName input) (Txt.pack $ unEscapeString v') qs
+    | '=':v' <- Txt.unpack p = renderInput form ix input [] $
+        (utf8 $ inputName input, Just $ utf8' $ unEscapeString v'):qs
+renderInput form ix input [p] qs
+    | '=':v' <- Txt.unpack p = renderInput form ix input [] $
+        set (inputName input) (Txt.pack $ unEscapeString v') qs
 renderInput form ix input@Input {inputType="checkbox", inputName=k', value=v'} [] qs
     | (utf8 k', Just $ utf8 v') `Prelude.elem` qs =
-        template "checkbox.html" form ix input [
-            q | q@(k, v) <- qs, k /= utf8 k', v /= Just (utf8 v')]
+        template "checkbox.html" form ix input $ unset k' v' qs
     | v' == "", (utf8 k', Nothing) `Prelude.elem` qs =
         template "checkbox.html" form ix input [
-            q | q@(k, v) <- qs, k /= utf8 k', v /= Nothing]
+            q | q@(k, v) <- qs, not (k == utf8 k' && v == Nothing)]
     | otherwise =
         template "checkbox.html" form ix input $ (utf8 k', Just $ utf8 v'):qs
 renderInput form ix input@Input {inputType="radio", inputName=k', value=v'} [] qs =
-    template "checkbox.html" form ix input $
-        (utf8 k', Just $ utf8 v'):[q | q@(k, _) <- qs, k /= utf8 k']
-renderInput _ _ _ _ _ = return Nothing
+    template "checkbox.html" form ix input $ set k' v' qs
+renderInput form ix input@Input { inputType="<select>" } [] qs =
+    template "select.html" form ix input qs
+renderInput _ _ input _ _ =
+    return $ Just $ Txt.concat ["Unknown input type: ", inputType input]
 
 utf8 :: Text -> ByteString
 utf8 = Txt.encodeUtf8
+utf8' :: String -> ByteString
+utf8' = utf8 . Txt.pack
+set :: Text -> Text -> [(ByteString, Maybe ByteString)]
+    -> [(ByteString, Maybe ByteString)]
+set k' v' qs = (utf8 k', Just $ utf8 v'):[q | q@(k, _) <- qs, k /= utf8 k']
+unset :: Text -> Text -> [(ByteString, Maybe ByteString)]
+    -> [(ByteString, Maybe ByteString)]
+unset k' v' qs = [q | q@(k, v) <- qs, not (k == utf8 k' && v == Just (utf8 v'))]
diff --git a/src/Text/HTML/Form/WebApp/Ginger.hs b/src/Text/HTML/Form/WebApp/Ginger.hs
index 418be96..88e8d40 100644
--- a/src/Text/HTML/Form/WebApp/Ginger.hs
+++ b/src/Text/HTML/Form/WebApp/Ginger.hs
@@ -10,7 +10,8 @@ import System.FilePath
 
 import Text.Ginger.Parse (parseGingerFile, SourcePos)
 import Text.Ginger.Run (runGinger, makeContextHtml, Run)
-import Text.Ginger.GVal as V (GVal(..), toGVal, ToGVal, orderedDict, (~>))
+import Text.Ginger.GVal as V (GVal(..), toGVal, ToGVal, orderedDict, (~>),
+        fromFunction, Function)
 import Text.Ginger.Html (Html, htmlSource, unsafeRawHtml)
 import Control.Monad.Writer.Lazy (Writer)
 
@@ -18,7 +19,7 @@ import Data.Text as Txt
 import Data.Text.Encoding as Txt
 import Data.Text.Lazy as Txt (toStrict)
 import Data.ByteString.Char8 as B8
-import Network.URI (uriToString)
+import Network.URI (uriToString, escapeURIString, isUnescapedInURIComponent)
 import Text.XML (Document(..), Element(..), Prologue(..), Node, def, renderText)
 
 import Data.List (nub)
@@ -40,22 +41,30 @@ template name form ix input query
     ctxt "inputs" = list' $ Prelude.map (flip input2gval query) $
         Prelude.zip [0..] $ inputs form
     ctxt "input" = input2gval (ix, input) query
+    ctxt "xURI" = fromFunction xURI
     ctxt _ = toGVal ()
+    xURI [(_, uri)] = let uri' = Txt.unpack $ asText uri in
+        return$toGVal$Txt.pack $ escapeURIString isUnescapedInURIComponent uri'
+    xURI _ = return $ toGVal ()
 
 resolveSource :: FilePath -> Maybe (Maybe [Char])
 resolveSource = Just . fmap B8.unpack .
     flip lookup $(makeRelativeToProject "tpl" >>= embedRecursiveDir) .
     ('/':) . normalise
 
-query2gval :: Query -> GVal m
+query2gval :: Monad m => Query -> GVal m
 query2gval qs =
-    (orderedDict [(Txt.decodeUtf8 k, list1 vs) | (k, vs) <- groupSort qs]) {
+    (orderedDict [(Txt.decodeUtf8 k, (list1 vs){ asFunction = Just $ gElem vs })
+            | (k, vs) <- groupSort qs]) {
         asText = Txt.pack q,
         asHtml = unsafeRawHtml $ Txt.pack q
     }
   where
     q = '?':renderQueryString' [(utf8 k, utf8 $ fromMaybe "" v) | (k, v) <- qs]
     utf8 = Txt.unpack . Txt.decodeUtf8
+    gElem :: Monad m => [ByteString] -> Function m
+    gElem xs [(_, x)] | Just x' <- asBytes x = return$toGVal$Prelude.elem x' xs
+    gElem _ _ = return $ toGVal ()
 
 form2gval :: Form -> GVal m
 form2gval form = orderedDict [
@@ -78,13 +87,17 @@ input2gval (ix, input) query = orderedDict [
     "inputType"   ~> inputType input,
     "dirName"     ~> dirname input,
     "name"        ~> inputName input,
-    "value"       ~> value input,
+    "value"       ~> if inputType input `Prelude.elem` ["radio", "checkbox"]
+        then value input
+        else Txt.intercalate ", " [Txt.decodeUtf8 v | (k, Just v) <- query,
+            Txt.encodeUtf8 (inputName input) == k],
     "autocomplete"~> inputAutocomplete input,
     "autofocus"   ~> autofocus input,
-    "checked"     ~> if value input == ""
+    "checked"     ~> (inputType input `Prelude.elem` ["radio", "checkbox"] &&
+        if value input== ""
         then isJust $ Prelude.lookup (Txt.encodeUtf8 $ inputName input) query
         else (Txt.encodeUtf8 $ inputName input,
-            Just $ Txt.encodeUtf8 $ value input) `Prelude.elem` query,
+            Just $ Txt.encodeUtf8 $ value input) `Prelude.elem` query),
     "disabled"    ~> disabled input,
     "readonly"    ~> readonly input,
     "multiple"    ~> multiple input,
@@ -96,7 +109,9 @@ input2gval (ix, input) query = orderedDict [
         "target"  ~> formTarget input
     ]),
     "inputmode"   ~> inputMode input,
-    ("list", list' $ Prelude.map optgroup2gval $ list input),
+    ("list", list' $ Prelude.map (optgroup2gval [v |
+            (k, Just v) <- query, Txt.decodeUtf8 k == inputName input])
+        $ list input),
     "min"         ~> fst (range input),
     "max"         ~> snd (range input),
     "step"        ~> step input,
@@ -122,17 +137,17 @@ html :: Node -> Html
 html node = unsafeRawHtml $ Txt.toStrict $ renderText def (
     Document (Prologue [] Nothing []) (Element "div" M.empty [node]) []
   )
-optgroup2gval :: OptionGroup -> GVal m
-optgroup2gval optgroup = orderedDict [
+optgroup2gval :: [ByteString] -> OptionGroup -> GVal m
+optgroup2gval query optgroup = orderedDict [
     "label"    ~> optsLabel optgroup,
     "disabled" ~> optsDisabled optgroup,
-    ("opts", list' $ Prelude.map opt2gval $ subopts optgroup)
+    ("opts", list' $ Prelude.map (opt2gval query) $ subopts optgroup)
   ]
-opt2gval :: Option -> GVal m
-opt2gval opt = orderedDict [
+opt2gval :: [ByteString] -> Option -> GVal m
+opt2gval query opt = orderedDict [
     "label"    ~> optLabel opt,
     "value"    ~> optValue opt,
-    "selected" ~> optSelected opt,
+    "selected" ~> (optValue opt `Prelude.elem` Prelude.map Txt.decodeUtf8 query),
     "disabled" ~> optDisabled opt
   ]
 
diff --git a/tpl/base.html b/tpl/base.html
index 0140e23..495deda 100644
--- a/tpl/base.html
+++ b/tpl/base.html
@@ -6,7 +6,7 @@
     body { background: black; color: #eee; font: medium sans-serif; }
     h1 { text-align: center }
     aside { width: 20%; border-right: thin solid #eee; }
-    dt { font-weight: bold }
+    dt { font-weight: bold; border-top: thin dashed #999; }
     dt a { color: inherit }
     .checked { color: lightgreen }
     .readonly { font-style: italic }
@@ -17,6 +17,10 @@
 
     main { display: flex; flex-direction: row; }
     section { padding: 20px }
+
+    nav { column-count: 4 } /* FIXME: Screen width issues? */
+    nav dl { margin: 0 }
+    dt, dd { break-inside: avoid }
   </style>
 </head>
 <body>
@@ -27,15 +31,26 @@
     <dt class="{% if input.checked %}checked{% endif %} {% if input.index == selected %}selected{% endif %}">
       {% if input.checked %}&check;{% endif %}
       {% if input.disabled %}{{ input.label }}
-      {% else %}<a href="/{{input.index}}{{Q}}" title="{{input.title}}">{{ input.label }}</a>
+      {% else %}<a href="/{{input.index}}/{{Q}}" title="{{input.title}}">{{ input.label }}</a>
       {% endif %}</dt>
     <dd class="{% if input.readonly %}readonly{% endif %}">{{ input.value }}</dd>
   {% endfor %}</dl></aside>
 
   {% block main %}
-    <section>
+    {% if input.list %}<aside><dl>{% for grp in input.list %}
+      <dt>{{ grp.label }}</dt>
+      {% for opt in grp.opts %}
+        {% if opt.disabled %}<dd>{{ opt.label }}</dd>
+        {% else %}<dd>
+          <a href="={{ opt.value|xURI }}" title="{{ opt.value }}">
+            {{ opt.label }}</a>
+        </dd>{% endif %}
+      {% endfor %}
+    {% endfor %}</dl></aside>{% endif %}
+
+    {% block control %}<section>
       {{ input.description }}
-    </section>
+    </section>{% endblock %}
   {% endblock %}
   </main>
 </body>
-- 
2.30.2