{-# 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 (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ TimeLocale -> String -> UTCTime -> String
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 Parser UTCTime -> Text -> Either String UTCTime
forall a. Parser a -> Text -> Either String a
AP.parseOnly (Parser UTCTime
parserUTCTime Parser UTCTime -> Parser Text () -> Parser UTCTime
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Text ()
forall t. Chunk t => Parser t ()
AP.endOfInput) Text
t of
    Left String
_  -> Maybe UTCTime
forall a. Maybe a
Nothing
    Right UTCTime
r -> UTCTime -> Maybe UTCTime
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 Parser Day -> Text -> Either String Day
forall a. Parser a -> Text -> Either String a
AP.parseOnly (Parser Day
parserDay Parser Day -> Parser Text () -> Parser Day
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Text ()
forall t. Chunk t => Parser t ()
AP.endOfInput) Text
t of
    Left String
_  -> Maybe Day
forall a. Maybe a
Nothing
    Right Day
r -> Day -> Maybe Day
forall a. a -> Maybe a
Just Day
r


parserUTCTime :: AP.Parser UTCTime
parserUTCTime :: Parser UTCTime
parserUTCTime = do
    Day
day <- Parser Day
parserDay
    Parser Text () -> Parser Text ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parser Text () -> Parser Text ())
-> Parser Text () -> Parser Text ()
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Parser Text ()
AP.skip (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'T')
    DiffTime
time <- Parser DiffTime
parserTime
    Maybe NominalDiffTime
mb_offset <- Parser (Maybe NominalDiffTime)
parserTimeZone
    UTCTime -> Parser UTCTime
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((UTCTime -> UTCTime)
-> (NominalDiffTime -> UTCTime -> UTCTime)
-> Maybe NominalDiffTime
-> UTCTime
-> UTCTime
forall b a. b -> (a -> b) -> Maybe a -> b
maybe UTCTime -> UTCTime
forall a. a -> a
id NominalDiffTime -> UTCTime -> UTCTime
addUTCTime Maybe NominalDiffTime
mb_offset (UTCTime -> UTCTime) -> UTCTime -> UTCTime
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 Day
parserDay = do
    Int
y :: Int <- Parser Int
forall a. Integral a => Parser a
AP.decimal Parser Int -> Parser Text Char -> Parser Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Text Char
AP.char Char
'-'
    Int
m :: Int <- Parser Int
forall a. Integral a => Parser a
AP.decimal Parser Int -> Parser Text Char -> Parser Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Text Char
AP.char Char
'-'
    Int
d :: Int <- Parser Int
forall a. Integral a => Parser a
AP.decimal
    case Integer -> Int -> Int -> Maybe Day
fromGregorianValid (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
y) Int
m Int
d of
        Just Day
x  -> Day -> Parser Day
forall (f :: * -> *) a. Applicative f => a -> f a
pure Day
x
        Maybe Day
Nothing -> String -> Parser Day
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 <- Parser Int
forall a. Integral a => Parser a
AP.decimal
    Parser Text Char -> Parser Text ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parser Text Char -> Parser Text ())
-> Parser Text Char -> Parser Text ()
forall a b. (a -> b) -> a -> b
$ Char -> Parser Text Char
AP.char Char
':'
    Int
m :: Int <- Parser 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 Text Char
AP.anyChar Parser Text Char
-> Parser Text Scientific -> Parser Text Scientific
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text Scientific
AP.scientific
           Maybe Char
_        -> Scientific -> Parser Text Scientific
forall (f :: * -> *) a. Applicative f => a -> f a
pure Scientific
0
    case Scientific -> Maybe Int
forall i. (Integral i, Bounded i) => Scientific -> Maybe i
toBoundedInteger (Scientific
10Scientific -> Int -> Scientific
forall a b. (Num a, Integral b) => a -> b -> a
^(Int
12::Int) Scientific -> Scientific -> Scientific
forall a. Num a => a -> a -> a
* (Scientific
s Scientific -> Scientific -> Scientific
forall a. Num a => a -> a -> a
+ Int -> Scientific
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
60Int -> Int -> Int
forall a. Num a => a -> a -> a
*(Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
60Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
h)))) of
      Just Int
n -> DiffTime -> Parser DiffTime
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer -> DiffTime
picosecondsToDiffTime (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
n :: Int)))
      Maybe Int
Nothing -> String -> Parser DiffTime
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 <- Char -> Parser Text Char -> Parser Text Char
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
AP.option Char
'Z' Parser Text Char
AP.anyChar
    case Char
c of
      Char
'Z' -> Maybe NominalDiffTime -> Parser (Maybe NominalDiffTime)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe NominalDiffTime
forall a. Maybe a
Nothing
      Char
' ' -> Parser Text Text
"UTC" Parser Text Text
-> Parser (Maybe NominalDiffTime) -> Parser (Maybe NominalDiffTime)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Maybe NominalDiffTime -> Parser (Maybe NominalDiffTime)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe NominalDiffTime
forall a. Maybe a
Nothing
      Char
'+' -> Bool -> Parser (Maybe NominalDiffTime)
forall a. Num a => Bool -> Parser Text (Maybe a)
parse_offset Bool
True
      Char
'-' -> Bool -> Parser (Maybe NominalDiffTime)
forall a. Num a => Bool -> Parser Text (Maybe a)
parse_offset Bool
False
      Char
_   -> String -> Parser (Maybe NominalDiffTime)
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 <- String -> Int
forall a. Read a => String -> a
read (String -> Int) -> Parser Text String -> Parser Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Parser Text Char -> Parser Text String
forall (m :: * -> *) a. Monad m => Int -> m a -> m [a]
AP.count Int
2 Parser Text Char
AP.digit
      () -> Parser Text () -> Parser Text ()
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
AP.option () ((Char -> Bool) -> Parser Text ()
AP.skip (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':'))
      Int
mm :: Int <- Int -> Parser Int -> Parser Int
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
AP.option Int
0 (String -> Int
forall a. Read a => String -> a
read (String -> Int) -> Parser Text String -> Parser Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Parser Text Char -> Parser Text String
forall (m :: * -> *) a. Monad m => Int -> m a -> m [a]
AP.count Int
2 Parser Text Char
AP.digit)
      let v :: Int
v = (if Bool
pos then Int -> Int
forall a. Num a => a -> a
negate else Int -> Int
forall a. a -> a
id) ((Int
hhInt -> Int -> Int
forall a. Num a => a -> a -> a
*Int
60 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
mm) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
60)
      Maybe a -> Parser Text (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Maybe a
forall a. a -> Maybe a
Just (Int -> a
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 (String -> Maybe UTCTime) -> String -> Maybe UTCTime
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
t

stringToUTC :: String -> Maybe UTCTime
stringToUTC :: String -> Maybe UTCTime
stringToUTC String
s = [UTCTime] -> Maybe UTCTime
forall a. [a] -> Maybe a
listToMaybe ([UTCTime] -> Maybe UTCTime) -> [UTCTime] -> Maybe UTCTime
forall a b. (a -> b) -> a -> b
$ [Maybe UTCTime] -> [UTCTime]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe UTCTime] -> [UTCTime]) -> [Maybe UTCTime] -> [UTCTime]
forall a b. (a -> b) -> a -> b
$
            (String -> Maybe UTCTime) -> [String] -> [Maybe UTCTime]
forall a b. (a -> b) -> [a] -> [b]
map (\String
fmt->Bool -> TimeLocale -> String -> String -> Maybe UTCTime
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 :: Text -> UTCTime
unsafeParseUTC Text
t = UTCTime -> Maybe UTCTime -> UTCTime
forall a. a -> Maybe a -> a
fromMaybe (String -> UTCTime
forall a. HasCallStack => String -> a
error String
msg) (Text -> Maybe UTCTime
parseUTC Text
t)
  where
    msg :: String
msg = String
"unsafeParseUTC: unable to parse: " String -> String -> String
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 :: Text -> Day
unsafeParseDay Text
t = Day -> Maybe Day -> Day
forall a. a -> Maybe a -> a
fromMaybe (String -> Day
forall a. HasCallStack => String -> a
error String
msg) (Text -> Maybe Day
parseDay Text
t)
  where
    msg :: String
msg = String
"unsafeParseDay: unable to parse: " String -> String -> String
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 = [Gen UTCTime] -> Gen UTCTime
forall a. [Gen a] -> Gen a
QC.oneof
        [ [UTCTime] -> Gen UTCTime
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
Text -> UTCTime
unsafeParseUTC