Format.hs

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

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

import Data.Time.Clock.Internal.UniversalTime
import Data.Time.Clock.Internal.UTCTime
import Data.Time.Clock.POSIX
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.LocalTime.Internal.TimeZone
import Data.Time.LocalTime.Internal.TimeOfDay
import Data.Time.LocalTime.Internal.LocalTime
import Data.Time.LocalTime.Internal.ZonedTime
import Data.Time.Format.Parse


type NumericPadOption = Maybe Char

-- the weird UNIX logic is here
getPadOption :: Bool -> Bool -> Int -> Char -> Maybe NumericPadOption -> Maybe Int -> PadOption
getPadOption trunc fdef idef cdef mnpad mi = let
    c = case mnpad of
        Just (Just c') -> c'
        Just Nothing -> ' '
        _ -> cdef
    i = case mi of
        Just i' -> case mnpad of
            Just Nothing -> i'
            _ -> if trunc then i' else max i' idef
        Nothing -> idef
    f = case mi of
        Just _ -> True
        Nothing -> case mnpad of
            Nothing -> fdef
            Just Nothing -> False
            Just (Just _) -> True
    in if f then Pad i c else NoPad

padGeneral :: Bool -> Bool -> Int -> Char -> (TimeLocale -> PadOption -> t -> String) -> (TimeLocale -> Maybe NumericPadOption -> Maybe Int -> t -> String)
padGeneral trunc fdef idef cdef ff locale mnpad mi = ff locale $ getPadOption trunc fdef idef cdef mnpad mi

padString :: (TimeLocale -> t -> String) -> (TimeLocale -> Maybe NumericPadOption -> Maybe Int -> t -> String)
padString ff = padGeneral False False 1 ' ' $ \locale pado -> showPadded pado . ff locale

padNum :: (Show i,Ord i,Num i) => Bool -> Int -> Char -> (t -> i) -> (TimeLocale -> Maybe NumericPadOption -> Maybe Int -> t -> String)
padNum fdef idef cdef ff = padGeneral False fdef idef cdef $ \_ pado -> showPaddedNum pado . ff

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

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

-- | Substitute various time-related information for each %-code in the string, as per 'formatCharacter'.
--
-- The general form is @%\<modifier\>\<width\>\<specifier\>@, where @\<modifier\>@ and @\<width\>@ are optional.
--
-- == @\<modifier\>@
-- glibc-style modifiers can be used before the specifier (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)
--
-- == @\<width\>@
-- Width digits can also be used after any modifiers and before the specifier (here marked as @z@), for example:
--
-- [@%4z@] pad to 4 characters (with default padding character)
--
-- [@%_12z@] pad with spaces to 12 characters
--
-- == @\<specifier\>@
--
-- For all types (note these three are done by 'formatTime', not by 'formatCharacter'):
--
-- [@%%@] @%@
--
-- [@%t@] tab
--
-- [@%n@] newline
--
-- === 'TimeZone'
-- For 'TimeZone' (and 'ZonedTime' and 'UTCTime'):
--
-- [@%z@] timezone offset in the format @-HHMM@.
--
-- [@%Z@] timezone name
--
-- === 'LocalTime'
-- For 'LocalTime' (and 'ZonedTime' and 'UTCTime' and 'UniversalTime'):
--
-- [@%c@] as 'dateTimeFmt' @locale@ (e.g. @%a %b %e %H:%M:%S %Z %Y@)
--
-- === 'TimeOfDay'
-- 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.
--
-- === 'UTCTime' and 'ZonedTime'
-- 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@.
--
-- === 'Day'
-- 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@
--
-- [@%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 ('%':cs) t = case formatTime1 locale cs t of
    Just result -> result
    Nothing -> '%':(formatTime locale cs t)
formatTime locale (c:cs) t = c:(formatTime locale cs t)

formatTime1 :: (FormatTime t) => TimeLocale -> String -> t -> Maybe String
formatTime1 locale ('_':cs) t = formatTime2 locale id (Just (Just ' ')) cs t
formatTime1 locale ('-':cs) t = formatTime2 locale id (Just Nothing) cs t
formatTime1 locale ('0':cs) t = formatTime2 locale id (Just (Just '0')) cs t
formatTime1 locale ('^':cs) t = formatTime2 locale (fmap toUpper) Nothing cs t
formatTime1 locale ('#':cs) t = formatTime2 locale (fmap toLower) Nothing cs t
formatTime1 locale cs t = formatTime2 locale id Nothing cs t

getDigit :: Char -> Maybe Int
getDigit c | c < '0' = Nothing
getDigit c | c > '9' = Nothing
getDigit c = Just $ (ord c) - (ord '0')

pullNumber :: Maybe Int -> String -> (Maybe Int,String)
pullNumber mx [] = (mx,[])
pullNumber mx s@(c:cs) = case getDigit c of
    Just i -> pullNumber (Just $ (fromMaybe 0 mx)*10+i) cs
    Nothing -> (mx,s)

formatTime2 :: (FormatTime t) => TimeLocale -> (String -> String) -> Maybe NumericPadOption -> String -> t -> Maybe String
formatTime2 locale recase mpad cs t = let
    (mwidth,rest) = pullNumber Nothing cs
    in formatTime3 locale recase mpad mwidth rest t

formatTime3 :: (FormatTime t) => TimeLocale -> (String -> String) -> Maybe NumericPadOption -> Maybe Int -> String -> t -> Maybe String
formatTime3 locale recase mpad mwidth (c:cs) t = Just $ (recase (formatChar c locale mpad mwidth t)) ++ (formatTime locale cs t)
formatTime3 _locale _recase _mpad _mwidth [] _t = Nothing

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

todAMPM :: TimeLocale -> TimeOfDay -> String
todAMPM locale day = let
    (am,pm) = amPm locale
    in if (todHour day) < 12 then am else pm

tod12Hour :: TimeOfDay -> Int
tod12Hour day = (mod (todHour day - 1) 12) + 1

showPaddedFixedFraction :: HasResolution a => PadOption -> Fixed a -> String
showPaddedFixedFraction pado x = let
    digits = dropWhile (=='.') $ dropWhile (/='.') $ showFixed True x
    n = length digits
    in case pado of
        NoPad -> digits
        Pad i c -> if i < n
            then take i digits
            else digits ++ replicate (i - n) c

instance FormatTime TimeOfDay where
    -- Aggregate
    formatCharacter 'R' = Just $ padString $ \locale -> formatTime locale "%H:%M"
    formatCharacter 'T' = Just $ padString $ \locale -> formatTime locale "%H:%M:%S"
    formatCharacter 'X' = Just $ padString $ \locale -> formatTime locale (timeFmt locale)
    formatCharacter 'r' = Just $ padString $ \locale -> formatTime locale (time12Fmt locale)
    -- AM/PM
    formatCharacter 'P' = Just $ padString $ \locale -> map toLower . todAMPM locale
    formatCharacter 'p' = Just $ padString $ \locale -> todAMPM locale
    -- Hour
    formatCharacter 'H' = Just $ padNum True  2 '0' todHour
    formatCharacter 'I' = Just $ padNum True  2 '0' tod12Hour
    formatCharacter 'k' = Just $ padNum True  2 ' ' todHour
    formatCharacter 'l' = Just $ padNum True  2 ' ' tod12Hour
    -- Minute
    formatCharacter 'M' = Just $ padNum True  2 '0' todMin
    -- Second
    formatCharacter 'S' = Just $ padNum True  2 '0' $ (floor . todSec :: TimeOfDay -> Int)
    formatCharacter 'q' = Just $ padGeneral True True 12 '0' $ \_ pado -> showPaddedFixedFraction pado . todSec
    formatCharacter 'Q' = Just $ padGeneral True False 12 '0' $ \_ pado -> ('.':) . showPaddedFixedFraction pado . todSec

    -- Default
    formatCharacter _   = Nothing

instance FormatTime ZonedTime where
    formatCharacter 'c' = Just $ padString $ \locale -> formatTime locale (dateTimeFmt locale)
    formatCharacter 's' = Just $ padNum True  1 '0' $ (floor . utcTimeToPOSIXSeconds . zonedTimeToUTC :: ZonedTime -> Integer)
    formatCharacter c = case formatCharacter c of
        Just f -> Just $ \locale mpado mwidth dt -> f locale mpado mwidth (zonedTimeToLocalTime dt)
        Nothing -> case formatCharacter c of
            Just f -> Just $ \locale mpado mwidth dt -> f locale mpado mwidth (zonedTimeZone dt)
            Nothing -> Nothing

instance FormatTime TimeZone where
    formatCharacter 'z' = Just $ padGeneral False True  4 '0' $ \_ pado -> showPadded pado . timeZoneOffsetString'' pado
    formatCharacter 'Z' = Just $ \locale mnpo mi z -> let
        n = timeZoneName z
        in if null n then timeZoneOffsetString'' (getPadOption False True 4 '0' mnpo mi) z else padString (\_ -> timeZoneName) locale mnpo mi z
    formatCharacter _ = Nothing

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

    -- Year Count
    formatCharacter 'Y' = Just $ padNum False 4 '0' $          fst . toOrdinalDate
    formatCharacter 'y' = Just $ padNum True  2 '0' $ mod100 . fst . toOrdinalDate
    formatCharacter 'C' = Just $ padNum False 2 '0' $ div100 . fst . toOrdinalDate
    -- Month of Year
    formatCharacter 'B' = Just $ padString $ \locale -> fst . (\(_,m,_) -> (months locale) !! (m - 1)) . toGregorian
    formatCharacter 'b' = Just $ padString $ \locale -> snd . (\(_,m,_) -> (months locale) !! (m - 1)) . toGregorian
    formatCharacter 'h' = Just $ padString $ \locale -> snd . (\(_,m,_) -> (months locale) !! (m - 1)) . toGregorian
    formatCharacter 'm' = Just $ padNum True  2 '0' $ (\(_,m,_) -> m) . toGregorian
    -- Day of Month
    formatCharacter 'd' = Just $ padNum True  2 '0' $ (\(_,_,d) -> d) . toGregorian
    formatCharacter 'e' = Just $ padNum True  2 ' ' $ (\(_,_,d) -> d) . toGregorian
    -- Day of Year
    formatCharacter 'j' = Just $ padNum True  3 '0' $ snd . toOrdinalDate

    -- ISO 8601 Week Date
    formatCharacter 'G' = Just $ padNum False 4 '0' $ (\(y,_,_) -> y) . toWeekDate
    formatCharacter 'g' = Just $ padNum True  2 '0' $ mod100 . (\(y,_,_) -> y) . toWeekDate
    formatCharacter 'f' = Just $ padNum False 2 '0' $ div100 . (\(y,_,_) -> y) . toWeekDate

    formatCharacter 'V' = Just $ padNum True  2 '0' $ (\(_,w,_) -> w) . toWeekDate
    formatCharacter 'u' = Just $ padNum True  1 '0' $ (\(_,_,d) -> d) . toWeekDate

    -- Day of week
    formatCharacter 'a' = Just $ padString $ \locale -> snd . ((wDays locale) !!) . snd . sundayStartWeek
    formatCharacter 'A' = Just $ padString $ \locale -> fst . ((wDays locale) !!) . snd . sundayStartWeek
    formatCharacter 'U' = Just $ padNum True  2 '0' $ fst . sundayStartWeek
    formatCharacter 'w' = Just $ padNum True  1 '0' $ snd . sundayStartWeek
    formatCharacter 'W' = Just $ padNum True  2 '0' $ fst . mondayStartWeek

    -- Default
    formatCharacter _   = Nothing

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

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