From 55731532baec4591f2055502054bc72407c65466 Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Thu, 16 Nov 2023 12:55:36 +1300 Subject: [PATCH] Get datepicker control working. Had to drop support for selecting dates Before-Christ, Hourglass doesn't appear to support those. --- form.html | 1 + src/Text/HTML/Form/WebApp.hs | 22 +++++- src/Text/HTML/Form/WebApp/Ginger/Hourglass.hs | 56 +++++++++---- tpl/gregorian.html | 78 +++++++++---------- 4 files changed, 101 insertions(+), 56 deletions(-) diff --git a/form.html b/form.html index c1cd39f..f5ddd39 100644 --- a/form.html +++ b/form.html @@ -17,6 +17,7 @@ + diff --git a/src/Text/HTML/Form/WebApp.hs b/src/Text/HTML/Form/WebApp.hs index d116dc8..53fd6da 100644 --- a/src/Text/HTML/Form/WebApp.hs +++ b/src/Text/HTML/Form/WebApp.hs @@ -15,8 +15,10 @@ import System.Directory (XdgDirectory(..), getXdgDirectory, doesFileExist, import Text.HTML.Form (Form(..), Input(..)) import Text.HTML.Form.WebApp.Ginger (template, template', resolveSource, list') import Text.HTML.Form.Query (renderQueryString, renderQuery') +import Text.HTML.Form.WebApp.Ginger.Hourglass (timeData, modifyTime', timeParseOrNow, + gSeqTo, gPad2) -import Text.Ginger.GVal as V (GVal(..), toGVal, orderedDict, (~>)) +import Text.Ginger.GVal as V (GVal(..), toGVal, orderedDict, (~>), fromFunction) import Text.Ginger.Html (html) type Query = [(ByteString, Maybe ByteString)] @@ -122,6 +124,24 @@ 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@Input { inputType = "date", inputName = n } [op] qs + | Just v <- modifyTime' op $ get n qs = do + -- TODO: Support other calendars + v' <- timeParseOrNow v + template' "gregorian.html" form ix input (set n (Txt.pack v) qs) $ + \x -> case x of + "T" -> timeData v' + "seqTo" -> fromFunction $ return . gSeqTo + "pad2" -> fromFunction $ return . gPad2 + _ -> toGVal () + | otherwise = return Nothing +renderInput form ix input@Input { inputType = "date", inputName = n } [] qs = do + v' <- timeParseOrNow $ get n qs + template' "gregorian.html" form ix input qs $ \x -> case x of -- TODO: Ditto + "T" -> timeData v' + "seqTo" -> fromFunction $ return . gSeqTo + "pad2" -> fromFunction $ return . gPad2 + _ -> toGVal () renderInput form ix input [keyboard] qs = renderInput form ix input [keyboard, ""] qs renderInput form ix input [keyboard, ""] qs | Just (Just _) <- resolveSource path = diff --git a/src/Text/HTML/Form/WebApp/Ginger/Hourglass.hs b/src/Text/HTML/Form/WebApp/Ginger/Hourglass.hs index bddad3f..c7d2f79 100644 --- a/src/Text/HTML/Form/WebApp/Ginger/Hourglass.hs +++ b/src/Text/HTML/Form/WebApp/Ginger/Hourglass.hs @@ -1,7 +1,8 @@ {-# LANGUAGE OverloadedStrings #-} -module Text.HTML.Form.WebApp.Ginger.Hourglass(timeData, modifyTime) where +module Text.HTML.Form.WebApp.Ginger.Hourglass( + timeData, modifyTime, modifyTime', timeParseOrNow, gSeqTo, gPad2) where -import Text.Ginger.GVal as V (GVal(..), toGVal, ToGVal, orderedDict, (~>)) +import Text.Ginger.GVal as V (GVal(..), toGVal, ToGVal, orderedDict, (~>), toInt) import Text.Ginger.Html (unsafeRawHtml) import Data.Hourglass import Time.System (localDateCurrent) @@ -11,7 +12,6 @@ import System.IO.Unsafe (unsafePerformIO) -- For use with localDateCurrent timeData :: LocalTime DateTime -> GVal a timeData datetime = orderedDict [ - "epoch" ~> if dateYear date < 0 then "BCE" :: String else "CE", "year" ~> abs (dateYear date), ("month", enumG $ dateMonth date), "date" ~> dateDay date, @@ -25,7 +25,7 @@ timeData datetime = orderedDict [ ("minute", enumG $ todMin $ dtTime $ localTimeUnwrap datetime), ("second", enumG $ todSec $ dtTime $ localTimeUnwrap datetime), ("nano", showG unwrapNanos $ todNSec $ dtTime $ localTimeUnwrap datetime), - ("timezone", showG timezoneOffsetToMinutes $ localTimeGetTimezone datetime), + ("zone", showG timezoneOffsetToMinutes $ localTimeGetTimezone datetime), "daysInMonth" ~> (dateYear date `daysInMonth` dateMonth date), ("monthStart", toGVal $ fromEnum $ getWeekDay date { dateDay = 1 }) ] @@ -65,32 +65,34 @@ modifyTime "-zone" time = offsetTZ time (-30) -- TODO Include a timezone databas modifyTime "+zone" time = offsetTZ time 30 modifyTime "now" _ = Just $ unsafePerformIO $ localDateCurrent modifyTime op time - | Just x' <- Txt.stripPrefix "year:" op, Just x <- readMaybe $ Txt.unpack x' = + | Just x' <- Txt.stripPrefix "year=" op, Just x <- readMaybe $ Txt.unpack x' = modLTime time $ \time' -> time' { dtDate = date { dateYear = toEnum x } } - | Just x' <- Txt.stripPrefix "month:" op, Just x <- readMaybe $ Txt.unpack x' = + | Just x' <- Txt.stripPrefix "month=" op, Just x <- readMaybe $ Txt.unpack x' = modLTime time $ \time' -> time' { dtDate = date { dateMonth = toEnum x } } - | Just x' <- Txt.stripPrefix "date:" op, Just x <- readMaybe $ Txt.unpack x' = + | Just x' <- Txt.stripPrefix "date=" op, Just x <- readMaybe $ Txt.unpack x' = modLTime time $ \time' -> time' { dtDate = date { dateDay = toEnum x } } - | Just x' <- Txt.stripPrefix "hour:" op, Just x <- readMaybe $ Txt.unpack x' = - modLTime time $ \time' -> time' { dtTime = time_ { todHour = toEnum x } } - | Just x' <- Txt.stripPrefix "minute:" op, Just x <- readMaybe $ Txt.unpack x' = + | Just x' <- Txt.stripPrefix "hour=" op, Just x <- readMaybe $ Txt.unpack x' = + modLTime time $ \time' -> time' { dtTime = time_ { + todHour = toEnum x + (if isAM then 0 else 12) + } } + | Just x' <- Txt.stripPrefix "minute=" op, Just x <- readMaybe $ Txt.unpack x' = modLTime time $ \time' -> time' { dtTime = time_ { todMin = toEnum x } } - | Just x' <- Txt.stripPrefix "second:" op, Just x <- readMaybe $ Txt.unpack x' = + | Just x' <- Txt.stripPrefix "second=" op, Just x <- readMaybe $ Txt.unpack x' = modLTime time $ \time' -> time' { dtTime = time_ { todSec = toEnum x } } - | Just x' <- Txt.stripPrefix "nano:" op, Just x <- readMaybe $ Txt.unpack x' = + | Just x' <- Txt.stripPrefix "nano=" op, Just x <- readMaybe $ Txt.unpack x' = modLTime time $ \time' -> time' { dtTime = time_ { todNSec = NanoSeconds x } } - | Just x' <- Txt.stripPrefix "zone:" op, Just x <- readMaybe $ Txt.unpack x' = + | Just x' <- Txt.stripPrefix "zone=" op, Just x <- readMaybe $ Txt.unpack x' = Just $ localTimeSetTimezone (TimezoneOffset x) time where date = dtDate $ localTimeUnwrap time time_ = dtTime $ localTimeUnwrap time + isAM | todHour time_ == 24 = True + | todHour time_ < 12 = True + | otherwise = False -- Written this way to avoid GHC complaining about us pattern-matching too much! Blasphemy! modifyTime op time = case op of "-year" -> addPeriod' time mempty { periodYears = -1 } "+year" -> addPeriod' time mempty { periodYears = 1 } - "epoch" -> modLTime time $ \time' -> time' { - dtDate = (dtDate time') { dateYear = -dateYear (dtDate time') } - } "-month" -> addPeriod' time mempty { periodMonths = -1 } "+month" -> addPeriod' time mempty { periodMonths = 1 } "-date" -> addPeriod' time mempty { periodDays = -1 } @@ -106,3 +108,25 @@ offsetTZ :: Time t => LocalTime t -> Int -> Maybe (LocalTime t) offsetTZ time mins = Just $ localTimeSetTimezone (TimezoneOffset $ timezoneOffsetToMinutes (localTimeGetTimezone time) + mins) time + +modifyTime' :: Txt.Text -> String -> Maybe String +modifyTime' op time + | Just ret <- modifyTime op $ unsafePerformIO $ timeParseOrNow time = + Just $ localTimePrint ISO8601_DateAndTime ret + | otherwise = Nothing +timeParseOrNow :: String -> IO (LocalTime DateTime) +timeParseOrNow txt = case localTimeParse ISO8601_DateAndTime txt of + Just ret -> return ret + Nothing -> localDateCurrent + +gSeqTo :: [(a, GVal m)] -> GVal m +gSeqTo [(_, from), (_, to)] + | Just x <- toInt from, Just y <- toInt to = toGVal [x..y] +gSeqTo [(_, from), (_, than), (_, to)] + | Just x <- toInt from, Just y <- toInt than, Just z <- toInt to = toGVal [x,y..z] +gSeqTo _ = toGVal () + +gPad2 :: [(a, GVal m)] -> GVal m +gPad2 [(_, x)] | Just y <- toInt x, y < 10 = toGVal $ '0':show x + | Just y <- toInt x = toGVal $ show y +gPad2 _ = toGVal () diff --git a/tpl/gregorian.html b/tpl/gregorian.html index 4c0e0ff..516d33f 100644 --- a/tpl/gregorian.html +++ b/tpl/gregorian.html @@ -5,67 +5,67 @@ .multi { display: flex } ul.control, .multi > ul { display: grid; + gap: 5px; grid-template-columns: repeat(3, min-content); list-style-type: none; } -

↓ - {{ year }} - ↑ - {{ epoch }} +

↓ + {{ T.year }} + ↑ - ↓ - {{ month }} - ↑ + ↓ + {{ T.month }} + ↑ - ↓ - {{ date }} - ↑ + ↓ + {{ T.date }} + ↑ - ↓ - {{ hour }} - ↑ + ↓ + {{ T.hour|pad2 }} + ↑ : - ↓ - {{ minute }} - ↑ - {{ meridiem }} + ↓ + {{ T.minute|pad2 }} + ↑ + {{ T.meridiem }} - ↓ - {{ zone }} - ↑

-

Now + ↓ + {{ T.zone }} + ↑

+

Now

-
{%- endblock -%} -- 2.30.2