{-# 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"
                        ]

-- | Render a 'UTCTime' in ISO 8601 format to a precision of seconds
-- (i.e. omitting any subseconds).
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

-- | Parse text as a 'UTCTime' in ISO 8601 format or a number of slight
-- variations thereof (the @T@ may be replaced with a space, and the seconds,
-- milliseconds and/or @Z@ timezone indicator may optionally be omitted).
--
-- Time zone designations other than @Z@ for UTC are not currently supported.
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

-- | Parse text as a 'Day' in @YYYY-MM-DD@ format.
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)

-- | Parser for @YYYY-MM-DD@ format.
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"

-- | Parser for times in the format @HH:MM@, @HH:MM:SS@ or @HH:MM:SS.QQQ...@.
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"

-- | Parser for time zone indications such as @Z@, @ UTC@ or an explicit offset
-- like @+HH:MM@ or @-HH@.  Returns 'Nothing' for UTC.  Local times (without a
-- timezone designator) are assumed to be UTC.  If there is an explicit offset,
-- returns its negation.
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))

-- | Parse text as a 'UTCTime' in ISO 8601 format or a number of slight
-- variations thereof (the @T@ may be replaced with a space, and the seconds and
-- timezone indicator may optionally be omitted).
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

-- | Variant of 'parseUTC' that throws an error if the input text could not be
-- parsed.
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

-- | Variant of 'parseDay' that throws an error if the input text could not be
-- parsed.
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


-- TODO: use a more arbitrary instance (quickcheck-instances?)
-- (in particular, there are no subsecond-resolution times here)
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