module Data.Thyme.Format
( FormatTime (..)
, formatTime
, ParseTime (..)
, parseTime
, TimeParse (..)
, timeParser
) where
import Prelude
import Control.Applicative
import Control.Lens
import Control.Monad.Trans.Class
import Control.Monad.Trans.State.Strict
import Data.Attoparsec.ByteString.Char8 (Parser)
import qualified Data.Attoparsec.ByteString.Char8 as P
import Data.Basis
import Data.Bits
import qualified Data.ByteString.Builder as S
import qualified Data.ByteString.Char8 as S
import qualified Data.ByteString.Lazy as SL
import Data.Char
import Data.Micro
import Data.Thyme.Calendar
import Data.Thyme.Calendar.Internal
import Data.Thyme.Calendar.MonthDay
import Data.Thyme.Clock.POSIX
import Data.Thyme.Clock.Scale
import Data.Thyme.Clock.UTC
import Data.Thyme.Format.Internal
import Data.Thyme.LocalTime
import Data.Thyme.TH
import Data.VectorSpace
import System.Locale
type FormatS = Char -> ShowS
class FormatTime t where
showsTime :: TimeLocale -> t -> FormatS -> FormatS
formatTime :: (FormatTime t) => TimeLocale -> String -> t -> String
formatTime l@TimeLocale {..} spec t = go spec "" where
format = showsTime l t (\ c s -> '%' : c : s)
go s = case s of
'%' : c : rest -> case c of
'c' -> go (dateTimeFmt ++ rest)
'r' -> go (time12Fmt ++ rest)
'X' -> go (timeFmt ++ rest)
'x' -> go (dateFmt ++ rest)
'-' -> go ('%' : rest)
'_' -> go ('%' : rest)
'0' -> go ('%' : rest)
'^' -> go ('%' : rest)
'#' -> go ('%' : rest)
'%' -> (:) '%' . go rest
_ -> format c . go rest
c : rest -> (:) c . go rest
[] -> id
showsYear :: Year -> ShowS
#if BUG_FOR_BUG
showsYear = shows
#else
showsYear = shows04
#endif
instance FormatTime TimeOfDay where
showsTime TimeLocale {..} (TimeOfDay h m (DiffTime s)) = \ def c -> case c of
'R' -> shows02 h . (:) ':' . shows02 m
'T' -> shows02 h . (:) ':' . shows02 m . (:) ':' . shows02 si
'P' -> (++) $ toLower <$> if h < 12 then fst amPm else snd amPm
'p' -> (++) $ if h < 12 then fst amPm else snd amPm
'H' -> shows02 h
'I' -> shows02 $ 1 + mod (h 1) 12
'k' -> shows_2 h
'l' -> shows_2 $ 1 + mod (h 1) 12
'M' -> shows02 m
'S' -> shows02 si
'q' -> fills06 su . shows su . (++) "000000"
'Q' -> if su == 0 then id else (:) '.' . fills06 su . drops0 su
_ -> def c
where (fromIntegral -> si, Micro su) = microQuotRem s (Micro 1000000)
instance FormatTime YearMonthDay where
showsTime TimeLocale {..} (YearMonthDay y m d) = \ def c -> case c of
'D' -> shows02 m . (:) '/' . shows02 d . (:) '/' . shows02 (mod y 100)
'F' -> showsYear y . (:) '-' . shows02 m . (:) '-' . shows02 d
'Y' -> showsYear y
'y' -> shows02 (mod y 100)
'C' -> shows02 (div y 100)
'B' -> (++) . fst $ months !! (m 1)
'b' -> (++) . snd $ months !! (m 1)
'h' -> (++) . snd $ months !! (m 1)
'm' -> shows02 m
'd' -> shows02 d
'e' -> shows_2 d
_ -> def c
instance FormatTime MonthDay where
showsTime TimeLocale {..} (MonthDay m d) = \ def c -> case c of
'B' -> (++) . fst $ months !! (m 1)
'b' -> (++) . snd $ months !! (m 1)
'h' -> (++) . snd $ months !! (m 1)
'm' -> shows02 m
'd' -> shows02 d
'e' -> shows_2 d
_ -> def c
instance FormatTime OrdinalDate where
showsTime TimeLocale {..} (OrdinalDate y d) = \ def c -> case c of
'Y' -> showsYear y
'y' -> shows02 (mod y 100)
'C' -> shows02 (div y 100)
'j' -> shows03 d
_ -> def c
instance FormatTime WeekDate where
showsTime TimeLocale {..} (WeekDate y w d) = \ def c -> case c of
'G' -> showsYear y
'g' -> shows02 (mod y 100)
'f' -> shows02 (div y 100)
'V' -> shows02 w
'u' -> shows $ if d == 0 then 7 else d
'w' -> shows $ if d == 7 then 0 else d
'A' -> (++) . fst $ wDays !! mod d 7
'a' -> (++) . snd $ wDays !! mod d 7
_ -> def c
instance FormatTime SundayWeek where
showsTime TimeLocale {..} (SundayWeek y w d) = \ def c -> case c of
'Y' -> showsYear y
'y' -> shows02 (mod y 100)
'C' -> shows02 (div y 100)
'U' -> shows02 w
'u' -> shows $ if d == 0 then 7 else d
'w' -> shows $ if d == 7 then 0 else d
'A' -> (++) . fst $ wDays !! mod d 7
'a' -> (++) . snd $ wDays !! mod d 7
_ -> def c
instance FormatTime MondayWeek where
showsTime TimeLocale {..} (MondayWeek y w d) = \ def c -> case c of
'Y' -> showsYear y
'y' -> shows02 (mod y 100)
'C' -> shows02 (div y 100)
'W' -> shows02 w
'u' -> shows $ if d == 0 then 7 else d
'w' -> shows $ if d == 7 then 0 else d
'A' -> (++) . fst $ wDays !! mod d 7
'a' -> (++) . snd $ wDays !! mod d 7
_ -> def c
instance FormatTime LocalTime where
showsTime l (LocalTime day tod) = showsTime l day . showsTime l tod
instance FormatTime Day where
showsTime l d@(view ordinalDate -> ordinal)
= showsTime l ordinal
. showsTime l (view yearMonthDay ordinal)
. showsTime l (toWeekOrdinal ordinal d)
. showsTime l (toSundayOrdinal ordinal d)
. showsTime l (toMondayOrdinal ordinal d)
instance FormatTime TimeZone where
showsTime _ tz@(TimeZone _ _ name) = \ def c -> case c of
'z' -> (++) (timeZoneOffsetString tz)
'Z' -> (++) (if null name then timeZoneOffsetString tz else name)
_ -> def c
instance FormatTime ZonedTime where
showsTime l (ZonedTime lt tz) = showsTime l lt . showsTime l tz
instance FormatTime UTCTime where
showsTime l t = \ def c -> case c of
's' -> shows . fst $ qr s (Micro 1000000)
_ -> showsTime l (view zonedTime (utc, t)) def c
where
NominalDiffTime s = view posixTime t
#if BUG_FOR_BUG
qr = microDivMod
#else
qr = microQuotRem
#endif
data TimeFlag
= PostMeridiem
| TwelveHour
| HasCentury
| IsPOSIXTime
| IsOrdinalDate
| IsGregorian
| IsWeekDate
| IsSundayWeek
| IsMondayWeek
deriving (Enum, Show)
data TimeParse = TimeParse
{ tpCentury :: !Int
, tpCenturyYear :: !Int
, tpMonth :: !Month
, tpWeekOfYear :: !WeekOfYear
, tpDayOfMonth :: !DayOfMonth
, tpDayOfYear :: !DayOfYear
, tpDayOfWeek :: !DayOfWeek
, tpFlags :: !Int
, tpHour :: !Hour
, tpMinute :: !Minute
, tpSecond :: !Int
, tpSecFrac :: !DiffTime
, tpPOSIXTime :: !POSIXTime
, tpTimeZone :: !TimeZone
} deriving (Show)
thymeLenses ''TimeParse
flag :: TimeFlag -> Simple Lens TimeParse Bool
flag (fromEnum -> f) = _tpFlags . lens
(`testBit` f) (\ n b -> (if b then setBit else clearBit) n f)
timeParser :: TimeLocale -> String -> Parser TimeParse
timeParser TimeLocale {..} = flip execStateT unixEpoch . go where
go :: String -> StateT TimeParse Parser ()
go spec = case spec of
'%' : cspec : rspec -> case cspec of
'c' -> go (dateTimeFmt ++ rspec)
'r' -> go (time12Fmt ++ rspec)
'X' -> go (timeFmt ++ rspec)
'x' -> go (dateFmt ++ rspec)
'R' -> go ("%H:%M" ++ rspec)
'T' -> go ("%H:%M:%S" ++ rspec)
'D' -> go ("%m/%d/%y" ++ rspec)
'F' -> go ("%Y-%m-%d" ++ rspec)
'P' -> dayHalf
'p' -> dayHalf
'H' -> lift (dec0 2) >>= setHour24
'I' -> lift (dec0 2) >>= setHour12
'k' -> lift (dec_ 2 <|> dec_ 1) >>= setHour24
'l' -> lift (dec_ 2 <|> dec_ 1) >>= setHour12
'M' -> lift (dec0 2) >>= assign _tpMinute >> go rspec
'S' -> lift (dec0 2) >>= assign _tpSecond >> go rspec
'q' -> lift micro >>= assign _tpSecFrac . DiffTime >> go rspec
'Q' -> lift ((P.char '.' >> DiffTime <$> micro) <|> return zeroV)
>>= assign _tpSecFrac >> go rspec
'Y' -> lift (dec0 4) >>= setYear
'y' -> lift (dec0 2) >>= setCenturyYear
'C' -> lift (dec0 2) >>= setCentury
'B' -> lift (indexOfCI $ fst <$> months) >>= setMonth . succ
'b' -> lift (indexOfCI $ snd <$> months) >>= setMonth . succ
'h' -> lift (indexOfCI $ snd <$> months) >>= setMonth . succ
'm' -> lift (dec0 2) >>= setMonth
'd' -> lift (dec0 2) >>= setDayOfMonth
'e' -> lift (dec_ 2 <|> dec_ 1) >>= setDayOfMonth
'j' -> lift (dec0 3) >>= assign _tpDayOfYear
>> flag IsOrdinalDate .= True >> go rspec
'G' -> flag IsWeekDate .= True >> lift (dec0 4) >>= setYear
'g' -> flag IsWeekDate .= True >> lift (dec0 2) >>= setCenturyYear
'f' -> flag IsWeekDate .= True >> lift (dec0 2) >>= setCentury
'V' -> flag IsWeekDate .= True >> lift (dec0 2) >>= setWeekOfYear
'U' -> flag IsSundayWeek .= True >> lift (dec0 2) >>= setWeekOfYear
'W' -> flag IsMondayWeek .= True >> lift (dec0 2) >>= setWeekOfYear
'w' -> lift (dec0 1) >>= setDayOfWeek
'u' -> lift (dec0 1) >>= setDayOfWeek
'A' -> lift (indexOfCI $ fst <$> wDays) >>= setDayOfWeek
'a' -> lift (indexOfCI $ snd <$> wDays) >>= setDayOfWeek
'z' -> do tzOffset; go rspec
'Z' -> do tzOffset <|> tzName; go rspec
's' -> do
s <- lift (negative P.decimal)
_tpPOSIXTime .= fromIntegral s *^ basisValue ()
flag IsPOSIXTime .= True
go rspec
'-' -> go ('%' : rspec)
'_' -> go ('%' : rspec)
'0' -> go ('%' : rspec)
'%' -> lift (P.char '%') >> go rspec
_ -> lift . fail $ "Unknown format character: " ++ show cspec
where
dayHalf = do
pm <- lift $ False <$ stringCI (fst amPm)
<|> True <$ stringCI (snd amPm)
flag PostMeridiem .= pm
flag TwelveHour .= True
go rspec
setHour12 h = do
flag TwelveHour .= True
_tpHour .= h
go rspec
setHour24 h = do
flag TwelveHour .= False
_tpHour .= h
go rspec
setYear ((`divMod` 100) -> (c, y)) = do
flag HasCentury .= True
_tpCentury .= c
_tpCenturyYear .= y
go rspec
setCenturyYear y = do _tpCenturyYear .= y; go rspec
setCentury c = do
_tpCentury .= c
flag HasCentury .= True
go rspec
setMonth m = do
flag IsGregorian .= True
_tpMonth .= m
go rspec
setDayOfMonth d = do
flag IsGregorian .= True
_tpDayOfMonth .= d
go rspec
setWeekOfYear w = do _tpWeekOfYear .= w; go rspec
setDayOfWeek d = do _tpDayOfWeek .= d; go rspec
tzOffset = do
s <- lift (id <$ P.char '+' <|> negate <$ P.char '-')
h <- lift (dec0 2)
() <$ lift (P.char ':') <|> pure ()
m <- lift (dec0 2)
_tpTimeZone . _timeZoneMinutes .= s (h * 60 + m)
tzName = lift timeZoneParser >>= assign _tpTimeZone
c : rspec | P.isSpace c ->
lift (P.takeWhile P.isSpace) >> go (dropWhile P.isSpace rspec)
c : rspec | isAscii c -> lift (P.char c) >> go rspec
c : rspec -> lift (charU8 c) >> go rspec
"" -> lift P.skipSpace
micro :: Parser Micro
micro = do
us10 <- either fail return . P.parseOnly P.decimal . S.take 7
. (`S.append` S.pack "000000") =<< P.takeWhile1 isDigit
return $ Micro (div (us10 + 5) 10)
unixEpoch :: TimeParse
unixEpoch = TimeParse {..} where
tpCentury = 19
tpCenturyYear = 70
tpMonth = 1
tpWeekOfYear = 1
tpDayOfYear = 1
tpDayOfMonth = 1
tpDayOfWeek = 4
tpFlags = 0
tpHour = 0
tpMinute = 0
tpSecond = 0
tpSecFrac = zeroV
tpPOSIXTime = zeroV
tpTimeZone = utc
parseTime :: (ParseTime t) => TimeLocale -> String -> String -> Maybe t
parseTime l spec = either (const Nothing) Just
. P.parseOnly (buildTime <$> timeParser l spec)
. SL.toStrict . S.toLazyByteString . S.stringUtf8
class ParseTime t where
buildTime :: TimeParse -> t
instance ParseTime TimeOfDay where
buildTime tp@TimeParse {..} = TimeOfDay h tpMinute
(fromIntegral tpSecond *^ basisValue () ^+^ tpSecFrac) where
h = case tp ^. flag TwelveHour of
False -> tpHour
True -> case tp ^. flag PostMeridiem of
False -> mod tpHour 12
True -> if tpHour < 12 then tpHour + 12 else tpHour
tpYear :: TimeParse -> Year
tpYear tp@TimeParse {..} = tpCenturyYear + 100 * if tp ^. flag HasCentury
then tpCentury else if tpCenturyYear < 69 then 20 else 19
instance ParseTime YearMonthDay where
buildTime tp@TimeParse {..} = YearMonthDay (tpYear tp) tpMonth tpDayOfMonth
instance ParseTime MonthDay where
buildTime TimeParse {..} = MonthDay tpMonth tpDayOfMonth
instance ParseTime OrdinalDate where
buildTime tp@TimeParse {..} = OrdinalDate (tpYear tp) tpDayOfYear
instance ParseTime WeekDate where
buildTime tp@TimeParse {..} = WeekDate (tpYear tp) tpWeekOfYear
(if tpDayOfWeek == 0 then 7 else tpDayOfWeek)
instance ParseTime SundayWeek where
buildTime tp@TimeParse {..} = SundayWeek (tpYear tp) tpWeekOfYear
(if tpDayOfWeek == 7 then 0 else tpDayOfWeek)
instance ParseTime MondayWeek where
buildTime tp@TimeParse {..} = MondayWeek (tpYear tp) tpWeekOfYear
(if tpDayOfWeek == 0 then 7 else tpDayOfWeek)
instance ParseTime LocalTime where
buildTime = LocalTime <$> buildTime <*> buildTime
instance ParseTime Day where
buildTime tp@TimeParse {..}
| tp ^. flag IsOrdinalDate = review ordinalDate (buildTime tp)
| tp ^. flag IsGregorian = review gregorian (buildTime tp)
| tp ^. flag IsWeekDate = review weekDate (buildTime tp)
| tp ^. flag IsSundayWeek = review sundayWeek (buildTime tp)
| tp ^. flag IsMondayWeek = review mondayWeek (buildTime tp)
| otherwise = review ordinalDate (buildTime tp)
instance ParseTime TimeZone where
buildTime = tpTimeZone
instance ParseTime ZonedTime where
buildTime = ZonedTime <$> buildTime <*> buildTime
instance ParseTime UTCTime where
buildTime tp@TimeParse {..} = if tp ^. flag IsPOSIXTime
then review posixTime tpPOSIXTime
else view (from zonedTime . _2) (buildTime tp)
timeZoneParser :: Parser TimeZone
timeZoneParser
= zone "ZULU" (($+) 00 00) False
<|> zone "Z" (($+) 00 00) False
<|> zone "YST" (($-) 09 00) False
<|> zone "YDT" (($-) 08 00) True
<|> zone "WST" (($+) 08 00) False
<|> zone "WETDST" (($+) 01 00) True
<|> zone "WET" (($+) 00 00) False
<|> zone "WDT" (($+) 09 00) True
<|> zone "WAT" (($-) 01 00) False
<|> zone "WAST" (($+) 07 00) False
<|> zone "WADT" (($+) 08 00) True
<|> zone "UTC" (($+) 00 00) False
<|> zone "UT" (($+) 00 00) False
<|> zone "TFT" (($+) 05 00) False
<|> zone "SWT" (($+) 01 00) False
<|> zone "SST" (($+) 02 00) False
<|> zone "SET" (($+) 01 00) False
<|> zone "SCT" (($+) 04 00) False
<|> zone "SAST" (($+) 09 30) False
<|> zone "SADT" (($+) 10 30) True
<|> zone "RET" (($+) 04 00) False
<|> zone "PST" (($-) 08 00) False
<|> zone "PDT" (($-) 07 00) True
<|> zone "NZT" (($+) 12 00) False
<|> zone "NZST" (($+) 12 00) False
<|> zone "NZDT" (($+) 13 00) True
<|> zone "NT" (($-) 11 00) False
<|> zone "NST" (($-) 03 30) False
<|> zone "NOR" (($+) 01 00) False
<|> zone "NFT" (($-) 03 30) False
<|> zone "NDT" (($-) 02 30) True
<|> zone "MVT" (($+) 05 00) False
<|> zone "MUT" (($+) 04 00) False
<|> zone "MT" (($+) 08 30) False
<|> zone "MST" (($-) 07 00) False
<|> zone "MMT" (($+) 06 30) False
<|> zone "MHT" (($+) 09 00) False
<|> zone "MEZ" (($+) 01 00) False
<|> zone "MEWT" (($+) 01 00) False
<|> zone "METDST" (($+) 02 00) True
<|> zone "MET" (($+) 01 00) False
<|> zone "MEST" (($+) 02 00) False
<|> zone "MDT" (($-) 06 00) True
<|> zone "MAWT" (($+) 06 00) False
<|> zone "MART" (($-) 09 30) False
<|> zone "LIGT" (($+) 10 00) False
<|> zone "KST" (($+) 09 00) False
<|> zone "JT" (($+) 07 30) False
<|> zone "JST" (($+) 09 00) False
<|> zone "IT" (($+) 03 30) False
<|> zone "IST" (($+) 02 00) False
<|> zone "IRT" (($+) 03 30) False
<|> zone "IOT" (($+) 05 00) False
<|> zone "IDLW" (($-) 12 00) False
<|> zone "IDLE" (($+) 12 00) False
<|> zone "HST" (($-) 10 00) False
<|> zone "HMT" (($+) 03 00) False
<|> zone "HDT" (($-) 09 00) True
<|> zone "GST" (($+) 10 00) False
<|> zone "GMT" (($+) 00 00) False
<|> zone "FWT" (($+) 02 00) False
<|> zone "FST" (($+) 01 00) False
<|> zone "FNT" (($-) 02 00) False
<|> zone "FNST" (($-) 01 00) False
<|> zone "EST" (($-) 05 00) False
<|> zone "EETDST" (($+) 03 00) True
<|> zone "EET" (($+) 02 00) False
<|> zone "EDT" (($-) 04 00) True
<|> zone "EAT" (($+) 03 00) False
<|> zone "EAST" (($+) 10 00) False
<|> zone "EAST" (($+) 04 00) False
<|> zone "DNT" (($+) 01 00) False
<|> zone "CXT" (($+) 07 00) False
<|> zone "CST" (($-) 06 00) False
<|> zone "CETDST" (($+) 02 00) True
<|> zone "CET" (($+) 01 00) False
<|> zone "CEST" (($+) 02 00) False
<|> zone "CDT" (($-) 05 00) True
<|> zone "CCT" (($+) 08 00) False
<|> zone "CAT" (($-) 10 00) False
<|> zone "CAST" (($+) 09 30) False
<|> zone "CADT" (($+) 10 30) True
<|> zone "BT" (($+) 03 00) False
<|> zone "BST" (($+) 01 00) False
<|> zone "BRT" (($-) 03 00) False
<|> zone "BRST" (($-) 02 00) False
<|> zone "BDST" (($+) 02 00) False
<|> zone "AWT" (($-) 03 00) False
<|> zone "AWST" (($+) 08 00) False
<|> zone "AWSST" (($+) 09 00) False
<|> zone "AST" (($-) 04 00) False
<|> zone "ALMT" (($+) 06 00) False
<|> zone "ALMST" (($+) 07 00) False
<|> zone "AKST" (($-) 09 00) False
<|> zone "AKDT" (($-) 08 00) True
<|> zone "AHST" (($-) 10 00) False
<|> zone "AFT" (($+) 04 30) False
<|> zone "AEST" (($+) 10 00) False
<|> zone "AESST" (($+) 11 00) False
<|> zone "ADT" (($-) 03 00) True
<|> zone "ACT" (($-) 05 00) False
<|> zone "ACST" (($-) 04 00) False
<|> zone "ACSST" (($+) 10 30) False
where
zone name offset dst = TimeZone offset dst name <$ P.string (S.pack name)
($+) h m = h * 60 + m
($-) h m = negate (h * 60 + m)