{-# 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DotNetTime -> DotNetTime -> Bool
$c/= :: DotNetTime -> DotNetTime -> Bool
== :: DotNetTime -> DotNetTime -> Bool
$c== :: DotNetTime -> DotNetTime -> Bool
Eq, Eq 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
min :: DotNetTime -> DotNetTime -> DotNetTime
$cmin :: DotNetTime -> DotNetTime -> DotNetTime
max :: DotNetTime -> DotNetTime -> DotNetTime
$cmax :: DotNetTime -> DotNetTime -> DotNetTime
>= :: DotNetTime -> DotNetTime -> Bool
$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
compare :: DotNetTime -> DotNetTime -> Ordering
$ccompare :: DotNetTime -> DotNetTime -> Ordering
Ord, ReadPrec [DotNetTime]
ReadPrec DotNetTime
Int -> ReadS DotNetTime
ReadS [DotNetTime]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [DotNetTime]
$creadListPrec :: ReadPrec [DotNetTime]
readPrec :: ReadPrec DotNetTime
$creadPrec :: ReadPrec DotNetTime
readList :: ReadS [DotNetTime]
$creadList :: ReadS [DotNetTime]
readsPrec :: Int -> ReadS DotNetTime
$creadsPrec :: Int -> ReadS DotNetTime
Read, Int -> DotNetTime -> ShowS
[DotNetTime] -> ShowS
DotNetTime -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DotNetTime] -> ShowS
$cshowList :: [DotNetTime] -> ShowS
show :: DotNetTime -> String
$cshow :: DotNetTime -> String
showsPrec :: Int -> DotNetTime -> ShowS
$cshowsPrec :: Int -> DotNetTime -> ShowS
Show, Typeable, TimeLocale -> DotNetTime -> (Char -> ShowS) -> Char -> ShowS
forall t.
(TimeLocale -> t -> (Char -> ShowS) -> Char -> ShowS)
-> FormatTime t
showsTime :: TimeLocale -> DotNetTime -> (Char -> ShowS) -> Char -> ShowS
$cshowsTime :: 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 forall a. [a] -> [a] -> [a]
++ forall t. FormatTime t => t -> String
formatMillis UTCTime
t forall a. [a] -> [a] -> [a]
++ String
")/"))
      where secs :: String
secs  = 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 = forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"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 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 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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (UTCTime -> DotNetTime
DotNetTime UTCTime
d)
             Maybe UTCTime
_      -> 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 forall a b. (a -> b) -> a -> b
$ String -> Text
pack forall a b. (a -> b) -> a -> b
$ forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
format ZonedTime
t
      where
        format :: String
format = String
"%FT%T." forall a. [a] -> [a] -> [a]
++ forall t. FormatTime t => t -> String
formatMillis ZonedTime
t forall a. [a] -> [a] -> [a]
++ String
tzFormat
        tzFormat :: String
tzFormat
          | Int
0 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 = forall a. Int -> [a] -> [a]
take Int
3 forall a b. (a -> b) -> a -> b
$ 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
      forall (f :: * -> *) a. Alternative f => f a -> f a -> f 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 forall t. ParseTime t => TimeLocale -> String -> String -> Maybe t
parseTime TimeLocale
defaultTimeLocale String
f (Text -> String
unpack Text
t) of
            Just a
d -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
d
            Maybe a
Nothing -> forall (f :: * -> *) a. Alternative f => f a
empty
        tryFormats :: [String] -> Parser ZonedTime
tryFormats = forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall {a} {f :: * -> *}.
(ParseTime a, Alternative f) =>
String -> f a
tryFormat
        alternateFormats :: [String]
alternateFormats =
          TimeLocale -> String
dateTimeFmt TimeLocale
defaultTimeLocale forall a. a -> [a] -> [a]
:
          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 =
          forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\a
x [a]
acc -> [a]
acc forall 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 = forall a b. (a -> b) -> [a] -> [b]
map (forall a. Monoid a => a -> a -> a
mappend b
x)

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

instance ToJSON UTCTime where
    toJSON :: UTCTime -> Value
toJSON UTCTime
t = Text -> Value
String forall a b. (a -> b) -> a -> b
$ String -> Text
pack forall a b. (a -> b) -> a -> b
$ forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
format UTCTime
t
      where
        format :: String
format = String
"%FT%T." forall a. [a] -> [a] -> [a]
++ forall t. FormatTime t => t -> String
formatMillis UTCTime
t forall a. [a] -> [a] -> [a]
++ String
"Z"
    {-# INLINE toJSON #-}

instance FromJSON UTCTime where
    parseJSON :: Value -> Parser UTCTime
parseJSON = forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"UTCTime" forall a b. (a -> b) -> a -> b
$ \Text
t ->
        case 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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure UTCTime
d
          Maybe UTCTime
_      -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"could not parse ISO-8601 date"
    {-# INLINE parseJSON #-}