~alcinnz/bureaucromancy

ref: 680706daf93b5e0ac346df89fe691735bf12b18e bureaucromancy/src/Text/HTML/Form/WebApp/Ginger/Hourglass.hs -rw-r--r-- 6.8 KiB
680706da — Adrian Cochrane Add week & color input support! 1 year, 1 month ago 
                                                                                
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
{-# LANGUAGE OverloadedStrings #-}
module Text.HTML.Form.WebApp.Ginger.Hourglass(
    timeData, modifyTime, modifyTime', timeParseOrNow, gSeqTo, gPad2) where

import Text.Ginger.GVal as V (GVal(..), toGVal, ToGVal, orderedDict, (~>), toInt)
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 [
    "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
        24 -> 12
        x -> x - 11),
    ("minute", enumG $ todMin $ dtTime $ localTimeUnwrap datetime),
    ("second", enumG $ todSec $ dtTime $ localTimeUnwrap datetime),
    ("nano", showG unwrapNanos $ todNSec $ dtTime $ localTimeUnwrap datetime),
    ("zone", 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 + (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' =
        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
    | 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
    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 }
    "-month" -> addPeriod' time mempty { periodMonths = -1 }
    "+month" -> addPeriod' time mempty { periodMonths = 1 }
    "-date" -> addPeriod' time mempty { periodDays = -1 }
    "+date" -> addPeriod' time mempty { periodDays = 1 }
    "-date7" -> addPeriod' time mempty { periodDays = -7 }
    "+date7" -> addPeriod' time mempty { periodDays = 7 }
    _ -> 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

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 ()