module Data.Thyme.Format
( FormatTime (..)
, formatTime
, ParseTime (..)
, parseTime
) where
import Prelude
import Control.Applicative
import Control.Lens
import Control.Monad.State.Strict hiding (get)
import Data.Attoparsec.ByteString.Char8 (Parser)
import qualified Data.Attoparsec.ByteString.Char8 as P
import Data.Basis
import Data.Bits
import qualified Data.ByteString.Char8 as S
import Data.Char
import Data.Int
import Data.Micro
import Data.Thyme.Calendar
import Data.Thyme.Calendar.MonthDay
import Data.Thyme.Calendar.OrdinalDate
import Data.Thyme.Calendar.WeekDate
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 qualified Data.Time.Format as T
import Data.VectorSpace
import System.Locale
class FormatTime t where
showsTime :: TimeLocale -> t -> (Char -> ShowS) -> (Char -> ShowS)
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)
fills06 :: Int64 -> ShowS
fills06 n
| n < 10 = (++) "00000"
| n < 100 = (++) "0000"
| n < 1000 = (++) "000"
| n < 10000 = (++) "00"
| n < 100000 = (++) "0"
| otherwise = id
drops0 :: Int64 -> ShowS
drops0 n = case divMod n 10 of
(q, 0) -> drops0 q
_ -> shows n
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 d
'A' -> (++) . fst $ wDays !! mod d 7
'a' -> (++) . snd $ wDays !! mod d 7
'w' -> shows (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 = showsTime l ordinal
. showsTime l (view yearMonthDay ordinal)
. showsTime l (view weekDate d) . other where
ordinal = view ordinalDate d
other :: (Char -> ShowS) -> (Char -> ShowS)
other def c = case c of
'U' -> shows02 . wdWeek $ sundayStartWeek d
'W' -> shows02 . wdWeek $ mondayStartWeek d
_ -> def c
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
| HasCentury
| IsPOSIXTime
| IsGregorian
| IsWeekDate
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@(shiftL 1 -> m@(complement -> m'))) = _tpFlags . lens
(`testBit` f) (\ n b -> if b then n .|. m else n .&. m')
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 (readsTime l spec) . S.pack
readsTime :: (ParseTime t) => TimeLocale -> String -> Parser t
readsTime l@TimeLocale {..} specString = buildTime
<$> execStateT (go specString) unixEpoch 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) >>= setHour24
'l' -> lift (dec_ 2) >>= 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) >>= assign _tpCenturyYear >> go rspec
'C' -> lift (dec0 2) >>= assign _tpCentury
>> flag HasCentury .= True >> go rspec
'm' -> lift (dec0 2) >>= setMonth
'd' -> lift (dec0 2) >>= setDayOfMonth
'e' -> lift (dec_ 2) >>= setDayOfMonth
'j' -> lift (dec0 3) >>= assign _tpDayOfYear >> go rspec
'G' -> lift (dec0 4) >>= \ y -> flag IsWeekDate .= True >> setYear y
'g' -> lift (dec0 2) >>= assign _tpCenturyYear
>> flag IsWeekDate .= True >> go rspec
'f' -> lift (dec0 2) >>= assign _tpCentury
>> flag IsWeekDate .= True >> flag HasCentury .= True >> go rspec
'V' -> lift (dec0 2) >>= setWeekOfYear
'U' -> lift (dec0 2) >>= setWeekOfYear
'W' -> lift (dec0 2) >>= setWeekOfYear
'u' -> lift (dec0 1) >>= setDayOfWeek
'w' -> lift (dec0 1) >>= setDayOfWeek
'z' -> timeZone "%z"
'Z' -> timeZone "%Z"
's' -> lift (negative P.decimal) >>= \ s -> flag IsPOSIXTime .= True
>> _tpPOSIXTime .= fromIntegral (s :: Int64) *^ basisValue ()
>> 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 <$ P.stringCI (S.pack $ fst amPm)
<|> True <$ P.stringCI (S.pack $ snd amPm)
flag PostMeridiem .= pm
go rspec
setHour12 h = do _tpHour .= h; go rspec
setHour24 h = do _tpHour .= h; go rspec; flag PostMeridiem .= False
setYear ((`divMod` 100) -> (c, y)) = flag HasCentury .= True
>> _tpCentury .= c >> _tpCenturyYear .= y >> go rspec
setMonth m = _tpMonth .= m >> go rspec
setDayOfMonth d = _tpDayOfMonth .= d
>> flag IsGregorian .= True >> go rspec
setWeekOfYear w = _tpWeekOfYear .= w
>> flag IsWeekDate .= True >> go rspec
setDayOfWeek d = _tpDayOfWeek .= d
>> flag IsWeekDate .= True >> go rspec
timeZone zspec = go rspec
c : rspec -> case isSpace c of
True -> lift (P.takeWhile1 isSpace) >> go (dropWhile isSpace rspec)
False -> lift (P.char c) >> go rspec
"" -> lift P.skipSpace
class ParseTime t where
buildTime :: TimeParse -> t
instance ParseTime TimeOfDay where
buildTime tp@TimeParse {..} = TimeOfDay h tpMinute
(fromIntegral tpSecond *^ basisValue () ^+^ tpSecFrac) where
h = if tp ^. flag PostMeridiem && tpHour < 12
then tpHour + 12 else tpHour
tpYear :: TimeParse -> Year
tpYear tp@TimeParse {..} = tpCenturyYear + 100 * if tp ^. flag HasCentury
then tpCentury else if tpCenturyYear < 70 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 tpDayOfWeek
instance ParseTime LocalTime where
buildTime = LocalTime <$> buildTime <*> buildTime
instance ParseTime Day where
buildTime tp@TimeParse {..}
| tp ^. flag IsGregorian = review gregorian (buildTime tp)
| tp ^. flag IsWeekDate = review weekDate (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)