From e55c9337f843c909832f29be8222c428fd8a8505 Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Mon, 13 Nov 2023 11:04:18 +1300 Subject: [PATCH] Draft date editting UI & accessors. --- bureaucromancy.cabal | 4 +- src/Text/HTML/Form/WebApp/Ginger/Hourglass.hs | 108 ++++++++++++++++++ tpl/gregorian.html | 71 ++++++++++++ 3 files changed, 181 insertions(+), 2 deletions(-) create mode 100644 src/Text/HTML/Form/WebApp/Ginger/Hourglass.hs create mode 100644 tpl/gregorian.html diff --git a/bureaucromancy.cabal b/bureaucromancy.cabal index 1fddcb0..7222203 100644 --- a/bureaucromancy.cabal +++ b/bureaucromancy.cabal @@ -63,7 +63,7 @@ library -- Modules exported by the library. exposed-modules: Text.HTML.Form, Text.HTML.Form.Query, - Text.HTML.Form.WebApp, Text.HTML.Form.WebApp.Ginger + Text.HTML.Form.WebApp, Text.HTML.Form.WebApp.Ginger, Text.HTML.Form.WebApp.Ginger.Hourglass -- Modules included in this library but not exported. -- other-modules: @@ -74,7 +74,7 @@ library -- Other library packages from which modules are imported. build-depends: base ^>=4.16.4.0, ginger, file-embed-lzma, file-embed, mtl, bytestring, text, xml-conduit, network-uri, regex-tdfa, containers, - filepath, directory + filepath, directory, hourglass >= 0.2.12 && < 0.3 -- Directories containing source files. hs-source-dirs: src diff --git a/src/Text/HTML/Form/WebApp/Ginger/Hourglass.hs b/src/Text/HTML/Form/WebApp/Ginger/Hourglass.hs new file mode 100644 index 0000000..bddad3f --- /dev/null +++ b/src/Text/HTML/Form/WebApp/Ginger/Hourglass.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE OverloadedStrings #-} +module Text.HTML.Form.WebApp.Ginger.Hourglass(timeData, modifyTime) where + +import Text.Ginger.GVal as V (GVal(..), toGVal, ToGVal, orderedDict, (~>)) +import Text.Ginger.Html (unsafeRawHtml) +import Data.Hourglass +import Time.System (localDateCurrent) +import qualified Data.Text as Txt +import Text.Read (readMaybe) +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, + "meridiem" ~> case todHour $ dtTime $ localTimeUnwrap datetime of + x | x < 12 -> "AM" :: String + 24 -> "AM" + _ -> "PM", + ("hour", enumG $ case todHour $ dtTime $ localTimeUnwrap datetime of + x | x <= 12 -> x + x -> x - 12), + ("minute", enumG $ todMin $ dtTime $ localTimeUnwrap datetime), + ("second", enumG $ todSec $ dtTime $ localTimeUnwrap datetime), + ("nano", showG unwrapNanos $ todNSec $ dtTime $ localTimeUnwrap datetime), + ("timezone", showG timezoneOffsetToMinutes $ localTimeGetTimezone datetime), + "daysInMonth" ~> (dateYear date `daysInMonth` dateMonth date), + ("monthStart", toGVal $ fromEnum $ getWeekDay date { dateDay = 1 }) + ] + where + date = dtDate $ localTimeUnwrap datetime + +enumG :: (Enum x, Show x) => x -> GVal a +enumG = showG fromEnum +showG :: (Show x, ToGVal m a) => (x -> a) -> x -> GVal m +showG cb x = (toGVal $ cb x) { + asText = Txt.pack $ show x, + asHtml = unsafeRawHtml $ Txt.pack $ show x + } +unwrapNanos :: NanoSeconds -> Int +unwrapNanos (NanoSeconds x) = fromEnum x + +modifyTime :: Txt.Text -> LocalTime DateTime -> Maybe (LocalTime DateTime) +modifyTime "-hour" time = modLTime time $ flip timeAdd mempty { durationHours = -1 } +modifyTime "+hour" time = modLTime time $ flip timeAdd mempty { durationHours = 1 } +modifyTime "-minute" time = modLTime time $ flip timeAdd mempty { durationMinutes = -1 } +modifyTime "+minute" time = modLTime time $ flip timeAdd mempty { durationMinutes = 1 } +modifyTime "meridiem" time = case todHour $ dtTime $ localTimeUnwrap time of + 12 -> modLTime time $ \time' -> time' { + dtTime = (dtTime time') { todHour = 24 } + } + x | x < 12 -> modLTime time $ \time' -> time' { + dtTime = (dtTime time') { todHour = x + 12 } + } + x -> modLTime time $ \time' -> time' { + dtTime = (dtTime time') { todHour = x - 12 } + } +modifyTime "-second" time = modLTime time $ flip timeAdd mempty { durationSeconds = -1 } +modifyTime "+second" time = modLTime time $ flip timeAdd mempty { durationSeconds = 1 } +modifyTime "-nano" time = modLTime time $ flip timeAdd mempty { durationNs = -1 } +modifyTime "+nano" time = modLTime time $ flip timeAdd mempty { durationNs = 1 } +modifyTime "-zone" time = offsetTZ time (-30) -- TODO Include a timezone database... +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' = + modLTime time $ \time' -> time' { dtDate = date { dateYear = toEnum 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' = + 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' = + modLTime time $ \time' -> time' { dtTime = time_ { todMin = toEnum 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' = + 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 + where + date = dtDate $ localTimeUnwrap time + time_ = dtTime $ localTimeUnwrap time +-- 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 } + "+date" -> addPeriod' time mempty { periodDays = 1 } + _ -> Nothing +modLTime :: LocalTime a -> (a -> b) -> Maybe (LocalTime b) +modLTime a = Just . flip fmap a +addPeriod' :: LocalTime DateTime -> Period -> Maybe (LocalTime DateTime) +addPeriod' time period = modLTime time $ \time' -> time' { + dtDate = dtDate time' `dateAddPeriod` period + } +offsetTZ :: Time t => LocalTime t -> Int -> Maybe (LocalTime t) +offsetTZ time mins = Just $ localTimeSetTimezone + (TimezoneOffset $ timezoneOffsetToMinutes (localTimeGetTimezone time) + mins) + time diff --git a/tpl/gregorian.html b/tpl/gregorian.html new file mode 100644 index 0000000..4c0e0ff --- /dev/null +++ b/tpl/gregorian.html @@ -0,0 +1,71 @@ +{% extends "base.html" %} + +{%- block control -%}
+ + +

↓ + {{ year }} + ↑ + {{ epoch }} + + ↓ + {{ month }} + ↑ + + ↓ + {{ date }} + ↑ + + ↓ + {{ hour }} + ↑ + : + ↓ + {{ minute }} + ↑ + {{ meridiem }} + + ↓ + {{ zone }} + ↑

+

Now + +

+ + +
    + {% for i in 1|seqTo(daysInMonth) %} +
  • + {{ i }} +
    • + {% endfor %} +
+ + + +
+
{%- endblock -%} -- 2.30.2