Format.hs

module Data.Time.Format
    (
    -- * UNIX-style formatting
    NumericPadOption,FormatTime(..),formatTime,
    module Data.Time.Format.Parse
    ) where

import Data.Time.Format.Parse

import Data.Time.LocalTime.TimeZone
import Data.Time.LocalTime.TimeOfDay
import Data.Time.LocalTime.LocalTime
import Data.Time.Calendar.Days
import Data.Time.Calendar.Gregorian
import Data.Time.Calendar.WeekDate
import Data.Time.Calendar.OrdinalDate
import Data.Time.Calendar.Private
import Data.Time.Clock.Scale
import Data.Time.Clock.UTC
import Data.Time.Clock.POSIX

import Data.Maybe
import Data.Char
import Data.Fixed

-- <http://www.opengroup.org/onlinepubs/007908799/xsh/strftime.html>
class FormatTime t where
    formatCharacter :: Char -> Maybe (TimeLocale -> Maybe NumericPadOption -> t -> String)

formatChar :: (FormatTime t) => Char -> TimeLocale -> Maybe NumericPadOption -> t -> String
formatChar '%' _ _ _ = "%"
formatChar 't' _ _ _ = "\t"
formatChar 'n' _ _ _ = "\n"
formatChar c locale mpado t = case (formatCharacter c) of
    Just f -> f locale mpado t
    _ -> ""

-- | Substitute various time-related information for each %-code in the string, as per 'formatCharacter'.
--
-- For all types (note these three are done here, not by 'formatCharacter'):
--
-- [@%%@] @%@
--
-- [@%t@] tab
--
-- [@%n@] newline
--
-- glibc-style modifiers can be used before the letter (here marked as @z@):
--
-- [@%-z@] no padding
--
-- [@%_z@] pad with spaces
--
-- [@%0z@] pad with zeros
--
-- [@%^z@] convert to upper case
--
-- [@%#z@] convert to lower case (consistently, unlike glibc)
--
-- For 'TimeZone' (and 'ZonedTime' and 'UTCTime'):
--
-- [@%z@] timezone offset in the format @-HHMM@.
--
-- [@%Z@] timezone name
--
-- For 'LocalTime' (and 'ZonedTime' and 'UTCTime' and 'UniversalTime'):
--
-- [@%c@] as 'dateTimeFmt' @locale@ (e.g. @%a %b %e %H:%M:%S %Z %Y@)
--
-- For 'TimeOfDay' (and 'LocalTime' and 'ZonedTime' and 'UTCTime' and 'UniversalTime'):
--
-- [@%R@] same as @%H:%M@
--
-- [@%T@] same as @%H:%M:%S@
--
-- [@%X@] as 'timeFmt' @locale@ (e.g. @%H:%M:%S@)
--
-- [@%r@] as 'time12Fmt' @locale@ (e.g. @%I:%M:%S %p@)
--
-- [@%P@] day-half of day from ('amPm' @locale@), converted to lowercase, @am@, @pm@
--
-- [@%p@] day-half of day from ('amPm' @locale@), @AM@, @PM@
--
-- [@%H@] hour of day (24-hour), 0-padded to two chars, @00@ - @23@
--
-- [@%k@] hour of day (24-hour), space-padded to two chars, @ 0@ - @23@
--
-- [@%I@] hour of day-half (12-hour), 0-padded to two chars, @01@ - @12@
--
-- [@%l@] hour of day-half (12-hour), space-padded to two chars, @ 1@ - @12@
--
-- [@%M@] minute of hour, 0-padded to two chars, @00@ - @59@
--
-- [@%S@] second of minute (without decimal part), 0-padded to two chars, @00@ - @60@
--
-- [@%q@] picosecond of second, 0-padded to twelve chars, @000000000000@ - @999999999999@.
--
-- [@%Q@] decimal point and fraction of second, up to 12 second decimals, without trailing zeros.
-- For a whole number of seconds, @%Q@ produces the empty string.
--
-- For 'UTCTime' and 'ZonedTime':
--
-- [@%s@] number of whole seconds since the Unix epoch. For times before
-- the Unix epoch, this is a negative number. Note that in @%s.%q@ and @%s%Q@
-- the decimals are positive, not negative. For example, 0.9 seconds
-- before the Unix epoch is formatted as @-1.1@ with @%s%Q@.
--
-- For 'Day' (and 'LocalTime' and 'ZonedTime' and 'UTCTime' and 'UniversalTime'):
--
-- [@%D@] same as @%m\/%d\/%y@
--
-- [@%F@] same as @%Y-%m-%d@
--
-- [@%x@] as 'dateFmt' @locale@ (e.g. @%m\/%d\/%y@)
--
-- [@%Y@] year, no padding. Note @%0Y@ and @%_Y@ pad to four chars
--
-- [@%y@] year of century, 0-padded to two chars, @00@ - @99@
--
-- [@%C@] century, no padding. Note @%0C@ and @%_C@ pad to two chars
--
-- [@%B@] month name, long form ('fst' from 'months' @locale@), @January@ - @December@
--
-- [@%b@, @%h@] month name, short form ('snd' from 'months' @locale@), @Jan@ - @Dec@
--
-- [@%m@] month of year, 0-padded to two chars, @01@ - @12@
--
-- [@%d@] day of month, 0-padded to two chars, @01@ - @31@
--
-- [@%e@] day of month, space-padded to two chars,  @ 1@ - @31@
--
-- [@%j@] day of year, 0-padded to three chars, @001@ - @366@
--
-- [@%G@] year for Week Date format, no padding. Note @%0G@ and @%_G@ pad to four chars
--
-- [@%g@] year of century for Week Date format, 0-padded to two chars, @00@ - @99@
--
-- [@%f@] century for Week Date format, no padding. Note @%0f@ and @%_f@ pad to two chars
--
-- [@%V@] week of year for Week Date format, 0-padded to two chars, @01@ - @53@
--
-- [@%u@] day of week for Week Date format, @1@ - @7@
--
-- [@%a@] day of week, short form ('snd' from 'wDays' @locale@), @Sun@ - @Sat@
--
-- [@%A@] day of week, long form ('fst' from 'wDays' @locale@), @Sunday@ - @Saturday@
--
-- [@%U@] week of year where weeks start on Sunday (as 'sundayStartWeek'), 0-padded to two chars, @00@ - @53@
--
-- [@%w@] day of week number, @0@ (= Sunday) - @6@ (= Saturday)
--
-- [@%W@] week of year where weeks start on Monday (as 'mondayStartWeek'), 0-padded to two chars, @00@ - @53@
formatTime :: (FormatTime t) => TimeLocale -> String -> t -> String
formatTime _ [] _ = ""
formatTime locale ('%':'_':c:cs) t = (formatChar c locale (Just (Just ' ')) t) ++ (formatTime locale cs t)
formatTime locale ('%':'-':c:cs) t = (formatChar c locale (Just Nothing) t) ++ (formatTime locale cs t)
formatTime locale ('%':'0':c:cs) t = (formatChar c locale (Just (Just '0')) t) ++ (formatTime locale cs t)
formatTime locale ('%':'^':c:cs) t = (fmap toUpper (formatChar c locale Nothing t)) ++ (formatTime locale cs t)
formatTime locale ('%':'#':c:cs) t = (fmap toLower (formatChar c locale Nothing t)) ++ (formatTime locale cs t)
formatTime locale ('%':c:cs) t = (formatChar c locale Nothing t) ++ (formatTime locale cs t)
formatTime locale (c:cs) t = c:(formatTime locale cs t)

instance FormatTime LocalTime where
    formatCharacter 'c' = Just (\locale _ -> formatTime locale (dateTimeFmt locale))
    formatCharacter c = case (formatCharacter c) of
        Just f -> Just (\locale mpado dt -> f locale mpado (localDay dt))
        Nothing -> case (formatCharacter c) of
            Just f -> Just (\locale mpado dt -> f locale mpado (localTimeOfDay dt))
            Nothing -> Nothing

instance FormatTime TimeOfDay where
    -- Aggregate
    formatCharacter 'R' = Just (\locale _ -> formatTime locale "%H:%M")
    formatCharacter 'T' = Just (\locale _ -> formatTime locale "%H:%M:%S")
    formatCharacter 'X' = Just (\locale _ -> formatTime locale (timeFmt locale))
    formatCharacter 'r' = Just (\locale _ -> formatTime locale (time12Fmt locale))
    -- AM/PM
    formatCharacter 'P' = Just (\locale _ day -> map toLower ((if (todHour day) < 12 then fst else snd) (amPm locale)))
    formatCharacter 'p' = Just (\locale _ day -> (if (todHour day) < 12 then fst else snd) (amPm locale))
    -- Hour
    formatCharacter 'H' = Just (\_ opt -> (show2 (fromMaybe (Just '0') opt)) . todHour)
    formatCharacter 'I' = Just (\_ opt -> (show2 (fromMaybe (Just '0') opt)) . (\h -> (mod (h - 1) 12) + 1) . todHour)
    formatCharacter 'k' = Just (\_ opt -> (show2 (fromMaybe (Just ' ') opt)) . todHour)
    formatCharacter 'l' = Just (\_ opt -> (show2 (fromMaybe (Just ' ') opt)) . (\h -> (mod (h - 1) 12) + 1) . todHour)
    -- Minute
    formatCharacter 'M' = Just (\_ opt -> (show2 (fromMaybe (Just '0') opt)) . todMin)
    -- Second
    formatCharacter 'S' = Just (\_ opt -> (show2 (fromMaybe (Just '0') opt) :: Int -> String) . truncate . todSec)
    formatCharacter 'q' = Just (\_ _ -> drop 1 . dropWhile (/='.') . showFixed False . todSec)
    formatCharacter 'Q' = Just (\_ _ -> dropWhile (/='.') . showFixed True . todSec)

    -- Default
    formatCharacter _   = Nothing

instance FormatTime ZonedTime where
    formatCharacter 'c' = Just (\locale _ -> formatTime locale (dateTimeFmt locale))
    formatCharacter 's' = Just (\_ _ zt -> show (floor (utcTimeToPOSIXSeconds (zonedTimeToUTC zt)) :: Integer))
    formatCharacter c = case (formatCharacter c) of
        Just f -> Just (\locale mpado dt -> f locale mpado (zonedTimeToLocalTime dt))
        Nothing -> case (formatCharacter c) of
            Just f -> Just (\locale mpado dt -> f locale mpado (zonedTimeZone dt))
            Nothing -> Nothing

instance FormatTime TimeZone where
    formatCharacter 'z' = Just (\_ opt -> timeZoneOffsetString' (fromMaybe (Just '0') opt))
    formatCharacter 'Z' =
            Just (\_ opt z -> let n = timeZoneName z
                           in if null n then timeZoneOffsetString' (fromMaybe (Just '0') opt) z else n)
    formatCharacter _ = Nothing

instance FormatTime Day where
    -- Aggregate
    formatCharacter 'D' = Just (\locale _ -> formatTime locale "%m/%d/%y")
    formatCharacter 'F' = Just (\locale _ -> formatTime locale "%Y-%m-%d")
    formatCharacter 'x' = Just (\locale _ -> formatTime locale (dateFmt locale))

    -- Year Count
    formatCharacter 'Y' = Just (\_ opt -> (show4 (fromMaybe Nothing opt)) . fst . toOrdinalDate)
    formatCharacter 'y' = Just (\_ opt -> (show2 (fromMaybe (Just '0') opt)) . mod100 . fst . toOrdinalDate)
    formatCharacter 'C' = Just (\_ opt -> (show2 (fromMaybe Nothing opt)) . div100 . fst . toOrdinalDate)
    -- Month of Year
    formatCharacter 'B' = Just (\locale _ -> fst . (\(_,m,_) -> (months locale) !! (m - 1)) . toGregorian)
    formatCharacter 'b' = Just (\locale _ -> snd . (\(_,m,_) -> (months locale) !! (m - 1)) . toGregorian)
    formatCharacter 'h' = Just (\locale _ -> snd . (\(_,m,_) -> (months locale) !! (m - 1)) . toGregorian)
    formatCharacter 'm' = Just (\_ opt -> (show2 (fromMaybe (Just '0') opt)) . (\(_,m,_) -> m) . toGregorian)
    -- Day of Month
    formatCharacter 'd' = Just (\_ opt -> (show2 (fromMaybe (Just '0') opt)) . (\(_,_,d) -> d) . toGregorian)
    formatCharacter 'e' = Just (\_ opt -> (show2 (fromMaybe (Just ' ') opt)) . (\(_,_,d) -> d) . toGregorian)
    -- Day of Year
    formatCharacter 'j' = Just (\_ opt -> (show3 (fromMaybe (Just '0') opt)) . snd . toOrdinalDate)

    -- ISO 8601 Week Date
    formatCharacter 'G' = Just (\_ opt -> (show4 (fromMaybe Nothing opt)) . (\(y,_,_) -> y) . toWeekDate)
    formatCharacter 'g' = Just (\_ opt -> (show2 (fromMaybe (Just '0') opt)) . mod100 . (\(y,_,_) -> y) . toWeekDate)
    formatCharacter 'f' = Just (\_ opt -> (show2 (fromMaybe Nothing opt)) . div100 . (\(y,_,_) -> y) . toWeekDate)

    formatCharacter 'V' = Just (\_ opt -> (show2 (fromMaybe (Just '0') opt)) . (\(_,w,_) -> w) . toWeekDate)
    formatCharacter 'u' = Just (\_ _ -> show . (\(_,_,d) -> d) . toWeekDate)

    -- Day of week
    formatCharacter 'a' = Just (\locale _ -> snd . ((wDays locale) !!) . snd . sundayStartWeek)
    formatCharacter 'A' = Just (\locale _ -> fst . ((wDays locale) !!) . snd . sundayStartWeek)
    formatCharacter 'U' = Just (\_ opt -> (show2 (fromMaybe (Just '0') opt)) . fst . sundayStartWeek)
    formatCharacter 'w' = Just (\_ _ -> show . snd . sundayStartWeek)
    formatCharacter 'W' = Just (\_ opt -> (show2 (fromMaybe (Just '0') opt)) . fst . mondayStartWeek)

    -- Default
    formatCharacter _   = Nothing

instance FormatTime UTCTime where
    formatCharacter c = fmap (\f locale mpado t -> f locale mpado (utcToZonedTime utc t)) (formatCharacter c)

instance FormatTime UniversalTime where
    formatCharacter c = fmap (\f locale mpado t -> f locale mpado (ut1ToLocalTime 0 t)) (formatCharacter c)