3 files changed, 181 insertions(+), 2 deletions(-)

M bureaucromancy.cabal
A src/Text/HTML/Form/WebApp/Ginger/Hourglass.hs
A tpl/gregorian.html

@@ 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

@@ 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

@@ 0,0 1,71 @@
+{% extends "base.html" %}
+
+{%- block control -%}<section>
+    <style>
+      .multi { display: flex }
+      ul.control, .multi > ul {
+        display: grid;
+        grid-template-columns: repeat(3, min-content);
+        list-style-type: none;
+      }
+    </style>
+
+    <p><a href="-year" title="Past year">↓</a>
+        <a href="year/" title="Edit year">{{ year }}</a>
+        <a href="+year" title="Next year">↑</a>
+        <a href="epoch" title="Toggle BCE/CE">{{ epoch }}</a>
+
+        <a href="-month" title="Past month">↓</a>
+        {{ month }}
+        <a href="+month" title="Next month">↑</a>
+
+        <a href="-date" title="Past day">↓</a>
+        {{ date }}
+        <a href="+date" title="Next day">↑</a>
+
+        <a href="-hour" title="Past hour">↓</a>
+        {{ hour }}
+        <a href="+hour" title="Next hour">↑</a>
+        :
+        <a href="-minute" title="Past minute">↓</a>
+        {{ minute }}
+        <a href="+minute" title="Next minute">↑</a>
+        <a href="meridiem" title="Toggle AM/PM">{{ meridiem }}</a>
+
+        <a href="-zone" title="Previous timezone">↓</a>
+        {{ zone }}
+        <a href="+zone" title="Next zone">↑</a></p>
+    <p><a href="now" title="Select current date & time">Now</a></a>
+
+    <div class="multi">
+      <ul>
+        <li><a href="month:0">January</a></li>
+        <li><a href="month:1">Febuary</a></li>
+        <li><a href="month:2">March</a></li>
+        <li><a href="month:3">April</a></li>
+        <li><a href="month:4">May</a></li>
+        <li><a href="month:5">June</a></li>
+        <li><a href="month:6">July</a></li>
+        <li><a href="month:7">August</a></li>
+        <li><a href="month:8">September</a></li>
+        <li><a href="month:9">October</a></li>
+        <li><a href="month:10">November</a></li>
+        <li><a href="month:11">December</a></li>
+      </ul>
+
+      <ul style="grid-template-columns: repeat(7, min-content)">
+        {% for i in 1|seqTo(daysInMonth) %}
+          <li {% if i == 1 %}style="grid-column: {{ monthStart }}"{% endif %}>
+            <a href="date:{{ i }}">{{ i }}</a>
+          </li>
+        {% endfor %}
+      </ul>
+
+      <ul>{% for i in 1|seqTo(12) %}
+        <li><a href="hour:{{ i }}">{{ i }}:{{ minute }}</a></li>
+      {% endfor %}</ul>
+      <ul>{% for i in 0|seqTo(60, 5) %}
+        <li><a href="minute:{{ i }}">{{ hour }}:{{ i|pad(2) }}</a></li>
+      {% endfor %}</ul>
+    </div>
+</section>{%- endblock -%}