{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

#if HLINT
#include "cabal_macros.h"
#endif

-- | Instances of 'FromJSON' and 'ToJSON' for 'UTCTime' and 'ZonedTime',
-- along with a newtype wrapper 'DotNetTime'.
module Data.Thyme.Format.Aeson
    ( DotNetTime (..)
    ) where

import Prelude
import Control.Applicative
import Data.Aeson hiding (DotNetTime (..))
import Data.Aeson.Types hiding (DotNetTime (..))
import Data.Data
#if !MIN_VERSION_base(4,8,0)
import Data.Monoid
#endif
import Data.Text (pack, unpack)
import qualified Data.Text as T
import Data.Thyme

-- Copyright:   (c) 2011, 2012, 2013 Bryan O'Sullivan
--              (c) 2011 MailRank, Inc.

------------------------------------------------------------------------
-- Copypasta from aeson-0.7.1.0:Data.Aeson.Types.Internal

-- | A newtype wrapper for 'UTCTime' that uses the same non-standard
-- serialization format as Microsoft .NET, whose @System.DateTime@
-- type is by default serialized to JSON as in the following example:
--
-- > /Date(1302547608878)/
--
-- The number represents milliseconds since the Unix epoch.
newtype DotNetTime = DotNetTime {
      DotNetTime -> UTCTime
fromDotNetTime :: UTCTime
    } deriving (DotNetTime -> DotNetTime -> Bool
(DotNetTime -> DotNetTime -> Bool)
-> (DotNetTime -> DotNetTime -> Bool) -> Eq DotNetTime
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DotNetTime -> DotNetTime -> Bool
== :: DotNetTime -> DotNetTime -> Bool
$c/= :: DotNetTime -> DotNetTime -> Bool
/= :: DotNetTime -> DotNetTime -> Bool
Eq, Eq DotNetTime
Eq DotNetTime =>
(DotNetTime -> DotNetTime -> Ordering)
-> (DotNetTime -> DotNetTime -> Bool)
-> (DotNetTime -> DotNetTime -> Bool)
-> (DotNetTime -> DotNetTime -> Bool)
-> (DotNetTime -> DotNetTime -> Bool)
-> (DotNetTime -> DotNetTime -> DotNetTime)
-> (DotNetTime -> DotNetTime -> DotNetTime)
-> Ord DotNetTime
DotNetTime -> DotNetTime -> Bool
DotNetTime -> DotNetTime -> Ordering
DotNetTime -> DotNetTime -> DotNetTime
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: DotNetTime -> DotNetTime -> Ordering
compare :: DotNetTime -> DotNetTime -> Ordering
$c< :: DotNetTime -> DotNetTime -> Bool
< :: DotNetTime -> DotNetTime -> Bool
$c<= :: DotNetTime -> DotNetTime -> Bool
<= :: DotNetTime -> DotNetTime -> Bool
$c> :: DotNetTime -> DotNetTime -> Bool
> :: DotNetTime -> DotNetTime -> Bool
$c>= :: DotNetTime -> DotNetTime -> Bool
>= :: DotNetTime -> DotNetTime -> Bool
$cmax :: DotNetTime -> DotNetTime -> DotNetTime
max :: DotNetTime -> DotNetTime -> DotNetTime
$cmin :: DotNetTime -> DotNetTime -> DotNetTime
min :: DotNetTime -> DotNetTime -> DotNetTime
Ord, ReadPrec [DotNetTime]
ReadPrec DotNetTime
Int -> ReadS DotNetTime
ReadS [DotNetTime]
(Int -> ReadS DotNetTime)
-> ReadS [DotNetTime]
-> ReadPrec DotNetTime
-> ReadPrec [DotNetTime]
-> Read DotNetTime
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS DotNetTime
readsPrec :: Int -> ReadS DotNetTime
$creadList :: ReadS [DotNetTime]
readList :: ReadS [DotNetTime]
$creadPrec :: ReadPrec DotNetTime
readPrec :: ReadPrec DotNetTime
$creadListPrec :: ReadPrec [DotNetTime]
readListPrec :: ReadPrec [DotNetTime]
Read, Int -> DotNetTime -> ShowS
[DotNetTime] -> ShowS
DotNetTime -> String
(Int -> DotNetTime -> ShowS)
-> (DotNetTime -> String)
-> ([DotNetTime] -> ShowS)
-> Show DotNetTime
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DotNetTime -> ShowS
showsPrec :: Int -> DotNetTime -> ShowS
$cshow :: DotNetTime -> String
show :: DotNetTime -> String
$cshowList :: [DotNetTime] -> ShowS
showList :: [DotNetTime] -> ShowS
Show, Typeable, TimeLocale -> DotNetTime -> (Char -> ShowS) -> Char -> ShowS
(TimeLocale -> DotNetTime -> (Char -> ShowS) -> Char -> ShowS)
-> FormatTime DotNetTime
forall t.
(TimeLocale -> t -> (Char -> ShowS) -> Char -> ShowS)
-> FormatTime t
$cshowsTime :: TimeLocale -> DotNetTime -> (Char -> ShowS) -> Char -> ShowS
showsTime :: TimeLocale -> DotNetTime -> (Char -> ShowS) -> Char -> ShowS
FormatTime)

------------------------------------------------------------------------
-- Copypasta from aeson-0.7.1.0:Data.Aeson.Types.Instances

instance ToJSON DotNetTime where
    toJSON :: DotNetTime -> Value
toJSON (DotNetTime UTCTime
t) =
        Text -> Value
String (String -> Text
pack (String
secs String -> ShowS
forall a. [a] -> [a] -> [a]
++ UTCTime -> String
forall t. FormatTime t => t -> String
formatMillis UTCTime
t String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")/"))
      where secs :: String
secs  = TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"/Date(%s" UTCTime
t
    {-# INLINE toJSON #-}

instance FromJSON DotNetTime where
    parseJSON :: Value -> Parser DotNetTime
parseJSON = String -> (Text -> Parser DotNetTime) -> Value -> Parser DotNetTime
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"DotNetTime" ((Text -> Parser DotNetTime) -> Value -> Parser DotNetTime)
-> (Text -> Parser DotNetTime) -> Value -> Parser DotNetTime
forall a b. (a -> b) -> a -> b
$ \Text
t ->
        let (Text
s,Text
m) = Int -> Text -> (Text, Text)
T.splitAt (Text -> Int
T.length Text
t Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
5) Text
t
            t' :: Text
t'    = [Text] -> Text
T.concat [Text
s,Text
".",Text
m]
        in case TimeLocale -> String -> String -> Maybe UTCTime
forall t. ParseTime t => TimeLocale -> String -> String -> Maybe t
parseTime TimeLocale
defaultTimeLocale String
"/Date(%s%Q)/" (Text -> String
unpack Text
t') of
             Just UTCTime
d -> DotNetTime -> Parser DotNetTime
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UTCTime -> DotNetTime
DotNetTime UTCTime
d)
             Maybe UTCTime
_      -> String -> Parser DotNetTime
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"could not parse .NET time"
    {-# INLINE parseJSON #-}

instance ToJSON ZonedTime where
    toJSON :: ZonedTime -> Value
toJSON ZonedTime
t = Text -> Value
String (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ TimeLocale -> String -> ZonedTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
format ZonedTime
t
      where
        format :: String
format = String
"%FT%T." String -> ShowS
forall a. [a] -> [a] -> [a]
++ ZonedTime -> String
forall t. FormatTime t => t -> String
formatMillis ZonedTime
t String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
tzFormat
        tzFormat :: String
tzFormat
          | Int
0 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== TimeZone -> Int
timeZoneMinutes (ZonedTime -> TimeZone
zonedTimeZone ZonedTime
t) = String
"Z"
          | Bool
otherwise = String
"%z"

formatMillis :: (FormatTime t) => t -> String
formatMillis :: forall t. FormatTime t => t -> String
formatMillis t
t = Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
3 ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ TimeLocale -> String -> t -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%q" t
t

instance FromJSON ZonedTime where
    parseJSON :: Value -> Parser ZonedTime
parseJSON (String Text
t) =
      [String] -> Parser ZonedTime
tryFormats [String]
alternateFormats
      Parser ZonedTime -> Parser ZonedTime -> Parser ZonedTime
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> Parser ZonedTime
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"could not parse ECMA-262 ISO-8601 date"
      where
        tryFormat :: String -> f a
tryFormat String
f =
          case TimeLocale -> String -> String -> Maybe a
forall t. ParseTime t => TimeLocale -> String -> String -> Maybe t
parseTime TimeLocale
defaultTimeLocale String
f (Text -> String
unpack Text
t) of
            Just a
d -> a -> f a
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
d
            Maybe a
Nothing -> f a
forall a. f a
forall (f :: * -> *) a. Alternative f => f a
empty
        tryFormats :: [String] -> Parser ZonedTime
tryFormats = (Parser ZonedTime -> Parser ZonedTime -> Parser ZonedTime)
-> [Parser ZonedTime] -> Parser ZonedTime
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Parser ZonedTime -> Parser ZonedTime -> Parser ZonedTime
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>) ([Parser ZonedTime] -> Parser ZonedTime)
-> ([String] -> [Parser ZonedTime]) -> [String] -> Parser ZonedTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Parser ZonedTime) -> [String] -> [Parser ZonedTime]
forall a b. (a -> b) -> [a] -> [b]
map String -> Parser ZonedTime
forall {a} {f :: * -> *}.
(ParseTime a, Alternative f) =>
String -> f a
tryFormat
        alternateFormats :: [String]
alternateFormats =
          TimeLocale -> String
dateTimeFmt TimeLocale
defaultTimeLocale String -> [String] -> [String]
forall a. a -> [a] -> [a]
:
          [String] -> [String] -> [String]
forall {t :: * -> *} {a}.
(Foldable t, Monoid a) =>
t a -> [a] -> [a]
distributeList [String
"%Y", String
"%Y-%m", String
"%F"]
                         [String
"T%R", String
"T%T", String
"T%T%Q", String
"T%T%QZ", String
"T%T%Q%z"]

        distributeList :: t a -> [a] -> [a]
distributeList t a
xs [a]
ys =
          (a -> [a] -> [a]) -> [a] -> t a -> [a]
forall a b. (a -> b -> b) -> b -> t a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\a
x [a]
acc -> [a]
acc [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ a -> [a] -> [a]
forall {b}. Monoid b => b -> [b] -> [b]
distribute a
x [a]
ys) [] t a
xs
        distribute :: b -> [b] -> [b]
distribute b
x = (b -> b) -> [b] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map (b -> b -> b
forall a. Monoid a => a -> a -> a
mappend b
x)

    parseJSON Value
v = String -> Value -> Parser ZonedTime
forall a. String -> Value -> Parser a
typeMismatch String
"ZonedTime" Value
v

instance ToJSON UTCTime where
    toJSON :: UTCTime -> Value
toJSON UTCTime
t = Text -> Value
String (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ String -> Text
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
format UTCTime
t
      where
        format :: String
format = String
"%FT%T." String -> ShowS
forall a. [a] -> [a] -> [a]
++ UTCTime -> String
forall t. FormatTime t => t -> String
formatMillis UTCTime
t String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"Z"
    {-# INLINE toJSON #-}

instance FromJSON UTCTime where
    parseJSON :: Value -> Parser UTCTime
parseJSON = String -> (Text -> Parser UTCTime) -> Value -> Parser UTCTime
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"UTCTime" ((Text -> Parser UTCTime) -> Value -> Parser UTCTime)
-> (Text -> Parser UTCTime) -> Value -> Parser UTCTime
forall a b. (a -> b) -> a -> b
$ \Text
t ->
        case TimeLocale -> String -> String -> Maybe UTCTime
forall t. ParseTime t => TimeLocale -> String -> String -> Maybe t
parseTime TimeLocale
defaultTimeLocale String
"%FT%T%QZ" (Text -> String
unpack Text
t) of
          Just UTCTime
d -> UTCTime -> Parser UTCTime
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UTCTime
d
          Maybe UTCTime
_      -> String -> Parser UTCTime
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"could not parse ISO-8601 date"
    {-# INLINE parseJSON #-}