module Penny.Copper.DateTime (
DefaultTimeZone(DefaultTimeZone, unDefaultTimeZone)
, dateTime
, utcDefault
, render
) where
import Control.Applicative ((<$>), optional, (<*>))
import qualified Data.Text as X
import Data.Time (fromGregorianValid)
import Data.Maybe (fromMaybe)
import qualified Data.Time as T
import Text.Parsec (char, digit, (<|>), (<?>))
import Text.Parsec.Text ( Parser )
import Control.Monad ( void, when )
import Data.Fixed ( Pico )
import System.Locale (defaultTimeLocale)
import Penny.Copper.Util (spaces)
import qualified Penny.Lincoln.Bits as B
newtype DefaultTimeZone =
DefaultTimeZone { unDefaultTimeZone :: B.TimeZoneOffset }
deriving (Eq, Show)
utcDefault :: DefaultTimeZone
utcDefault = DefaultTimeZone B.noOffset
charToDigit :: Char -> Int
charToDigit c = case c of
'0' -> 0
'1' -> 1
'2' -> 2
'3' -> 3
'4' -> 4
'5' -> 5
'6' -> 6
'7' -> 7
'8' -> 8
'9' -> 9
_ -> error "unrecognized digit"
read2digits :: Parser Int
read2digits = f <$> digit <*> digit where
f d1 d2 = charToDigit d1 * 10 + charToDigit d2
read4digits :: Parser Integer
read4digits = f <$> digit <*> digit <*> digit <*> digit where
f d1 d2 d3 d4 = fromIntegral $
charToDigit d1 * 1000
+ charToDigit d2 * 100
+ charToDigit d3 * 10
+ charToDigit d4
date :: Parser T.Day
date = do
let slash = void $ char '/' <|> char '-'
y <- read4digits
slash
m <- read2digits
slash
d <- read2digits
case fromGregorianValid y m d of
Nothing -> fail "invalid date"
Just dt -> return dt
colon :: Parser ()
colon = void $ char ':'
hrs :: Parser Int
hrs = do
h <- read2digits
when (h > 23) $ fail "invalid hour"
return h
mins :: Parser Int
mins = do
m <- read2digits
when (m > 59) $ fail "invalid minute"
return m
secs :: Parser Pico
secs = do
s <- fromIntegral <$> read2digits
when (s > 59) $ fail "invalid seconds"
return s
timeOfDay :: Parser T.TimeOfDay
timeOfDay = do
h <- hrs
colon
m <- mins
maybeS <- optional (colon >> secs)
let s = fromMaybe (fromIntegral (0 :: Int)) maybeS
return $ T.TimeOfDay h m s
timeZoneOffset :: Parser B.TimeZoneOffset
timeZoneOffset = do
changeSign <-
(char '+' >> return id)
<|> (char '-' >> return (negate :: Int -> Int))
<?> "time zone sign"
h <- read2digits
m <- read2digits
let mi = h * 60 + m
maybe (fail "invalid time zone offset") return
$ B.minsToOffset (changeSign mi)
dateTime :: DefaultTimeZone -> Parser B.DateTime
dateTime (DefaultTimeZone dtz) = do
d <- date
spaces
mayTod <- optional timeOfDay
spaces
mayTz <- optional timeZoneOffset
let tod = fromMaybe T.midnight mayTod
tz = fromMaybe dtz mayTz
return (B.dateTime (T.LocalTime d tod) tz)
render :: DefaultTimeZone -> B.DateTime -> X.Text
render (DefaultTimeZone dtz) dt = let
lt = B.localTime dt
off = B.timeZone dt
fmtLong = "%F %T %z"
fmtShort = "%F"
sameZone = dtz == off
local = T.localTimeOfDay lt
isMidnight = local == T.midnight
fmt = if sameZone && isMidnight
then fmtShort
else fmtLong
zt = T.ZonedTime lt (T.minutesToTimeZone (B.offsetToMins off))
in X.pack $ T.formatTime defaultTimeLocale fmt zt