{-# 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
x -> x - 12),
("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 }
_ -> 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 ()