From 9a651302a3fbc7565fb9a755470a269baea161ab Mon Sep 17 00:00:00 2001
From: Adrian Cochrane <adrian@openwork.nz>
Date: Fri, 17 Nov 2023 15:51:38 +1300
Subject: [PATCH] Implement a year numpad!

---
 src/Text/HTML/Form/WebApp.hs                  | 7 +++++++
 src/Text/HTML/Form/WebApp/Ginger/Hourglass.hs | 8 ++++++++
 2 files changed, 15 insertions(+)

diff --git a/src/Text/HTML/Form/WebApp.hs b/src/Text/HTML/Form/WebApp.hs
index 53fd6da..5445488 100644
--- a/src/Text/HTML/Form/WebApp.hs
+++ b/src/Text/HTML/Form/WebApp.hs
@@ -33,6 +33,13 @@ renderPage _ _ _ = return Nothing
 renderInput :: Form -> Int -> Input -> [Text] -> [(ByteString, Maybe ByteString)] ->
     IO (Maybe (Either Query Text))
 renderInput form ix input [""] qs = renderInput form ix input [] qs
+renderInput form ix input@Input { inputType = "date", inputName = name } ["year", p] qs
+    | Just t <- modifyTime' (Txt.pack $ "year/" ++ Txt.unpack p) $ get name qs = do
+        t' <- timeParseOrNow t
+        template' "cal/year-numpad.html" form ix input (set name (Txt.pack t) qs) $
+            \prop -> case prop of
+                "T" -> timeData t'
+                _ -> toGVal ()
 renderInput form ix input@Input { multiple = True } [p] qs
     | '=':v' <- Txt.unpack p,
             (utf8 $ inputName input, Just $ utf8' v') `Prelude.elem` qs =
diff --git a/src/Text/HTML/Form/WebApp/Ginger/Hourglass.hs b/src/Text/HTML/Form/WebApp/Ginger/Hourglass.hs
index c7d2f79..d071569 100644
--- a/src/Text/HTML/Form/WebApp/Ginger/Hourglass.hs
+++ b/src/Text/HTML/Form/WebApp/Ginger/Hourglass.hs
@@ -83,6 +83,14 @@ modifyTime op time
         modLTime time $ \time' -> time' { dtTime = time_ { todNSec = NanoSeconds x } }
     | Just x' <- Txt.stripPrefix "zone=" op, Just x <- readMaybe $ Txt.unpack x' =
         Just $ localTimeSetTimezone (TimezoneOffset x) time
+    | Just x' <- Txt.stripPrefix "year/:" op, Just x <- readMaybe $ Txt.unpack x' =
+        modLTime time $ \time' -> time' {
+            dtDate = date { dateYear = dateYear date * 10 + x }
+          }
+    | "year/-" <- op = modLTime time $ \time' -> time' {
+            dtDate = date { dateYear = dateYear date `div` 10 }
+          }
+    | "year/" <- op = Just time -- Noop, allow viewer.
   where
     date = dtDate $ localTimeUnwrap time
     time_ = dtTime $ localTimeUnwrap time
-- 
2.30.2