{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wwarn=orphans #-}
module Data.API.Time
( printUTC
, parseUTC
, parseDay
, unsafeParseUTC
, unsafeParseDay
, parseUTC_old
) where
import Control.Monad
import qualified Data.Attoparsec.Text as AP
import Data.Maybe
import Data.Scientific
import qualified Data.Text as T
import Data.Time
import GHC.Stack
import Test.QuickCheck as QC
utcFormat :: String
utcFormat :: String
utcFormat = String
"%Y-%m-%dT%H:%M:%SZ"
utcFormats :: [String]
utcFormats :: [String]
utcFormats =
[ String
"%Y-%m-%dT%H:%M:%S%Z"
, String
"%Y-%m-%dT%H:%M:%S"
, String
"%Y-%m-%dT%H:%M%Z"
, String
"%Y-%m-%dT%H:%M"
, String
"%Y-%m-%dT%H:%M:%S%QZ"
, String
utcFormat
, String
"%Y-%m-%d %H:%M:%S"
, String
"%Y-%m-%d %H:%M:%S%Z"
, String
"%Y-%m-%d %H:%M:%S%QZ"
, String
"%Y-%m-%d %H:%M%Z"
, String
"%Y-%m-%d %H:%M"
]
printUTC :: UTCTime -> T.Text
printUTC :: UTCTime -> Text
printUTC UTCTime
utct = String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
utcFormat UTCTime
utct
parseUTC :: T.Text -> Maybe UTCTime
parseUTC :: Text -> Maybe UTCTime
parseUTC Text
t = case forall a. Parser a -> Text -> Either String a
AP.parseOnly (Parser Text UTCTime
parserUTCTime forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall t. Chunk t => Parser t ()
AP.endOfInput) Text
t of
Left String
_ -> forall a. Maybe a
Nothing
Right UTCTime
r -> forall a. a -> Maybe a
Just UTCTime
r
parseDay :: T.Text -> Maybe Day
parseDay :: Text -> Maybe Day
parseDay Text
t = case forall a. Parser a -> Text -> Either String a
AP.parseOnly (Parser Text Day
parserDay forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall t. Chunk t => Parser t ()
AP.endOfInput) Text
t of
Left String
_ -> forall a. Maybe a
Nothing
Right Day
r -> forall a. a -> Maybe a
Just Day
r
parserUTCTime :: AP.Parser UTCTime
parserUTCTime :: Parser Text UTCTime
parserUTCTime = do
Day
day <- Parser Text Day
parserDay
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Parser Text ()
AP.skip (\Char
c -> Char
c forall a. Eq a => a -> a -> Bool
== Char
' ' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'T')
DiffTime
time <- Parser DiffTime
parserTime
Maybe NominalDiffTime
mb_offset <- Parser (Maybe NominalDiffTime)
parserTimeZone
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id NominalDiffTime -> UTCTime -> UTCTime
addUTCTime Maybe NominalDiffTime
mb_offset forall a b. (a -> b) -> a -> b
$ Day -> DiffTime -> UTCTime
UTCTime Day
day DiffTime
time)
parserDay :: AP.Parser Day
parserDay :: Parser Text Day
parserDay = do
Int
y :: Int <- forall a. Integral a => Parser a
AP.decimal forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Char
AP.char Char
'-'
Int
m :: Int <- forall a. Integral a => Parser a
AP.decimal forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Char
AP.char Char
'-'
Int
d :: Int <- forall a. Integral a => Parser a
AP.decimal
case Integer -> Int -> Int -> Maybe Day
fromGregorianValid (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
y) Int
m Int
d of
Just Day
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Day
x
Maybe Day
Nothing -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"invalid date"
parserTime :: AP.Parser DiffTime
parserTime :: Parser DiffTime
parserTime = do
Int
h :: Int <- forall a. Integral a => Parser a
AP.decimal
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Char -> Parser Char
AP.char Char
':'
Int
m :: Int <- forall a. Integral a => Parser a
AP.decimal
Maybe Char
c <- Parser (Maybe Char)
AP.peekChar
Scientific
s <- case Maybe Char
c of
Just Char
':' -> Parser Char
AP.anyChar forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text Scientific
AP.scientific
Maybe Char
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Scientific
0
case forall i. (Integral i, Bounded i) => Scientific -> Maybe i
toBoundedInteger (Scientific
10forall a b. (Num a, Integral b) => a -> b -> a
^(Int
12::Int) forall a. Num a => a -> a -> a
* (Scientific
s forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
60forall a. Num a => a -> a -> a
*(Int
m forall a. Num a => a -> a -> a
+ Int
60forall a. Num a => a -> a -> a
*Int
h)))) of
Just Int
n -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer -> DiffTime
picosecondsToDiffTime (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
n :: Int)))
Maybe Int
Nothing -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"seconds out of range"
parserTimeZone :: AP.Parser (Maybe NominalDiffTime)
parserTimeZone :: Parser (Maybe NominalDiffTime)
parserTimeZone = do
Char
c <- forall (f :: * -> *) a. Alternative f => a -> f a -> f a
AP.option Char
'Z' Parser Char
AP.anyChar
case Char
c of
Char
'Z' -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
Char
' ' -> Parser Text Text
"UTC" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
Char
'+' -> forall {a}. Num a => Bool -> Parser Text (Maybe a)
parse_offset Bool
True
Char
'-' -> forall {a}. Num a => Bool -> Parser Text (Maybe a)
parse_offset Bool
False
Char
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"unexpected time zone character"
where
parse_offset :: Bool -> Parser Text (Maybe a)
parse_offset Bool
pos = do
Int
hh :: Int <- forall a. Read a => String -> a
read forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. Monad m => Int -> m a -> m [a]
AP.count Int
2 Parser Char
AP.digit
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
AP.option () ((Char -> Bool) -> Parser Text ()
AP.skip (forall a. Eq a => a -> a -> Bool
== Char
':'))
Int
mm :: Int <- forall (f :: * -> *) a. Alternative f => a -> f a -> f a
AP.option Int
0 (forall a. Read a => String -> a
read forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. Monad m => Int -> m a -> m [a]
AP.count Int
2 Parser Char
AP.digit)
let v :: Int
v = (if Bool
pos then forall a. Num a => a -> a
negate else forall a. a -> a
id) ((Int
hhforall a. Num a => a -> a -> a
*Int
60 forall a. Num a => a -> a -> a
+ Int
mm) forall a. Num a => a -> a -> a
* Int
60)
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
v))
parseUTC_old :: T.Text -> Maybe UTCTime
parseUTC_old :: Text -> Maybe UTCTime
parseUTC_old Text
t = String -> Maybe UTCTime
stringToUTC forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
t
stringToUTC :: String -> Maybe UTCTime
stringToUTC :: String -> Maybe UTCTime
stringToUTC String
s = forall a. [a] -> Maybe a
listToMaybe forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$
forall a b. (a -> b) -> [a] -> [b]
map (\String
fmt->forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> String -> String -> m t
parseTimeM Bool
True TimeLocale
defaultTimeLocale String
fmt String
s) [String]
utcFormats
unsafeParseUTC :: HasCallStack => T.Text -> UTCTime
unsafeParseUTC :: HasCallStack => Text -> UTCTime
unsafeParseUTC Text
t = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
error String
msg) (Text -> Maybe UTCTime
parseUTC Text
t)
where
msg :: String
msg = String
"unsafeParseUTC: unable to parse: " forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack Text
t
unsafeParseDay :: HasCallStack => T.Text -> Day
unsafeParseDay :: HasCallStack => Text -> Day
unsafeParseDay Text
t = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
error String
msg) (Text -> Maybe Day
parseDay Text
t)
where
msg :: String
msg = String
"unsafeParseDay: unable to parse: " forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack Text
t
instance QC.Arbitrary UTCTime where
arbitrary :: Gen UTCTime
arbitrary = forall a. [Gen a] -> Gen a
QC.oneof
[ forall a. [a] -> Gen a
QC.elements [Text -> UTCTime
mk Text
"2010-01-01T00:00:00Z"
, Text -> UTCTime
mk Text
"2013-05-27T19:13:50Z"
, Text -> UTCTime
mk Text
"2011-07-20T22:04:00Z"
, Text -> UTCTime
mk Text
"2012-02-02T15:45:11Z"
, Text -> UTCTime
mk Text
"2009-11-12T20:57:54Z"
, Text -> UTCTime
mk Text
"2000-10-28T21:03:24Z"
, Text -> UTCTime
mk Text
"1965-03-10T09:23:01Z"
]]
where
mk :: Text -> UTCTime
mk = HasCallStack => Text -> UTCTime
unsafeParseUTC