{-# 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