From 63b2d96888ce65692da0e62ca4a9ab5611695237 Mon Sep 17 00:00:00 2001
From: Adrian Cochrane <adrian@openwork.nz>
Date: Tue, 7 Nov 2023 10:22:35 +1300
Subject: [PATCH] Add numpad for number & range inputs

---
 form.html                    |  2 ++
 src/Text/HTML/Form/WebApp.hs | 16 ++++++++++++++++
 tpl/number.html              | 10 ++++++----
 tpl/tel.html                 | 32 ++++++++++++++++++++++++++++++++
 4 files changed, 56 insertions(+), 4 deletions(-)
 create mode 100644 tpl/tel.html

diff --git a/form.html b/form.html
index 6561c09..c1cd39f 100644
--- a/form.html
+++ b/form.html
@@ -15,6 +15,8 @@
     <label><input type="email" name="email" />eMail</label>
     <label><input type="tel" name="tel" />Telephone</label>
     <label><input type="url" name="site" />Homepage</label>
+    <label><input type="number" name="numerator" />Numerator</label>
+    <label><input type="range" min="1" max="42" name="denominator" />Denominator</label>
   </form>
 </body>
 </html>
diff --git a/src/Text/HTML/Form/WebApp.hs b/src/Text/HTML/Form/WebApp.hs
index ac643dc..d116dc8 100644
--- a/src/Text/HTML/Form/WebApp.hs
+++ b/src/Text/HTML/Form/WebApp.hs
@@ -48,6 +48,12 @@ renderInput form ix input [p] qs
         renderInput form ix input [] $ set (inputName input)
             (Txt.pack $ Prelude.init v') qs
     | "-" <- Txt.unpack p = renderInput form ix input [] qs
+    | '+':x' <- Txt.unpack p, Just x <- readMaybe x' :: Maybe Double,
+            Just y <- readMaybe $ get (inputName input) qs =
+        renderInput form ix input [] $
+            set (inputName input) (Txt.pack $ show $ x + y) qs
+    | '+':x' <- Txt.unpack p, Just _ <- readMaybe x' :: Maybe Double =
+        renderInput form ix input [] $ set (inputName input) (Txt.pack x') qs
 renderInput form ix input [x, p] qs
     | '=':v' <- Txt.unpack p = renderInput form ix input [x] $
         set (inputName input) (Txt.pack $ unEscapeString v') qs
@@ -58,6 +64,12 @@ renderInput form ix input [x, p] qs
         renderInput form ix input [x] $ set (inputName input)
             (Txt.pack $ Prelude.init v') qs
     | "-" <- Txt.unpack p = renderInput form ix input [x] qs
+    | '+':z' <- Txt.unpack p, Just z <- readMaybe z' :: Maybe Double,
+            Just y <- readMaybe $ get (inputName input) qs =
+        renderInput form ix input [x] $
+            set (inputName input) (Txt.pack $ show $ z + y) qs
+    | '+':x' <- Txt.unpack p, Just _ <- readMaybe x' :: Maybe Double =
+        renderInput form ix input [x] $ set (inputName input) (Txt.pack x') 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 $ unset k' v' qs
@@ -105,6 +117,10 @@ renderInput form ix input@Input { inputType="file" } path qs = do
       ]
     doesDirectoryExist' parent file = doesDirectoryExist $ parent </> file
 renderInput form ix input@Input { inputType = "tel" } [] qs =
+    template "tel.html" form ix input qs
+renderInput form ix input@Input { inputType = "number" } [] qs =
+    template "number.html" form ix input qs
+renderInput form ix input@Input { inputType = "range" } [] qs =
     template "number.html" form ix input qs
 renderInput form ix input [keyboard] qs =
     renderInput form ix input [keyboard, ""] qs
diff --git a/tpl/number.html b/tpl/number.html
index 992d576..77f3474 100644
--- a/tpl/number.html
+++ b/tpl/number.html
@@ -1,7 +1,9 @@
 {% extends "base.html" %}
 
 {%- block control -%}<section>
-  <p>{{ input.value }}</p>
+  <p><a href="+-{{input.step|default(1)}}{{Q}}">↓</a>
+    {{ input.value }}
+    <a href="+{{input.step|default(1)}}{{Q}}">↑</a></p>
   <hr />
   <table>
     <tr>
@@ -23,10 +25,10 @@
       <td><a href="-{{Q}}">DEL</a></td>
     </tr>
     <tr>
-      <td><a href=":*{{Q}}">*</a></td>
-      <td><a href=":0{{Q}}">0</a></td>
-      <td><a href=":#{{Q}}">#</a></td>
       <td><a href=":.{{Q}}">.</a></td>
+      <td><a href=":0{{Q}}">0</a></td>
+      <td><a href=":,{{Q}}">,</a></td>
+      <td><a href="={{Q}}">CLEAR</a></td>
     </tr>
   </table>
 </section>{%- endblock -%}
diff --git a/tpl/tel.html b/tpl/tel.html
new file mode 100644
index 0000000..992d576
--- /dev/null
+++ b/tpl/tel.html
@@ -0,0 +1,32 @@
+{% extends "base.html" %}
+
+{%- block control -%}<section>
+  <p>{{ input.value }}</p>
+  <hr />
+  <table>
+    <tr>
+      <td><a href=":7{{Q}}">7</a></td>
+      <td><a href=":8{{Q}}">8</a></td>
+      <td><a href=":9{{Q}}">9</a></td>
+      <td><a href=":-{{Q}}">-</a></td>
+    </tr>
+    <tr>
+      <td><a href=":4{{Q}}">4</a></td>
+      <td><a href=":5{{Q}}">5</a></td>
+      <td><a href=":6{{Q}}">6</a></td>
+      <td><a href=":%20{{Q}}">SPACE</a></td>
+    </tr>
+    <tr>
+      <td><a href=":1{{Q}}">1</a></td>
+      <td><a href=":2{{Q}}">2</a></td>
+      <td><a href=":3{{Q}}">3</a></td>
+      <td><a href="-{{Q}}">DEL</a></td>
+    </tr>
+    <tr>
+      <td><a href=":*{{Q}}">*</a></td>
+      <td><a href=":0{{Q}}">0</a></td>
+      <td><a href=":#{{Q}}">#</a></td>
+      <td><a href=":.{{Q}}">.</a></td>
+    </tr>
+  </table>
+</section>{%- endblock -%}
-- 
2.30.2