{-# 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 }
    _ -> 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 ()