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

-- | 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
import Data.Monoid
import Data.Text (pack, unpack)
import qualified Data.Text as T
import Data.Thyme
import System.Locale

-- 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
/= :: DotNetTime -> DotNetTime -> Bool
$c/= :: DotNetTime -> DotNetTime -> Bool
== :: DotNetTime -> DotNetTime -> Bool
$c== :: 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
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
$cp1Ord :: Eq 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
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
(Int -> DotNetTime -> ShowS)
-> (DotNetTime -> String)
-> ([DotNetTime] -> ShowS)
-> Show DotNetTime
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
(TimeLocale -> DotNetTime -> (Char -> ShowS) -> Char -> ShowS)
-> FormatTime DotNetTime
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 t :: 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]
++ ")/"))
      where secs :: String
secs  = TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale "/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 "DotNetTime" ((Text -> Parser DotNetTime) -> Value -> Parser DotNetTime)
-> (Text -> Parser DotNetTime) -> Value -> Parser DotNetTime
forall a b. (a -> b) -> a -> b
$ \t :: Text
t ->
        let (s :: Text
s,m :: Text
m) = Int -> Text -> (Text, Text)
T.splitAt (Text -> Int
T.length Text
t Int -> Int -> Int
forall a. Num a => a -> a -> a
- 5) Text
t
            t' :: Text
t'    = [Text] -> Text
T.concat [Text
s,".",Text
m]
        in case TimeLocale -> String -> String -> Maybe UTCTime
forall t. ParseTime t => TimeLocale -> String -> String -> Maybe t
parseTime TimeLocale
defaultTimeLocale "/Date(%s%Q)/" (Text -> String
unpack Text
t') of
             Just d :: UTCTime
d -> DotNetTime -> Parser DotNetTime
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UTCTime -> DotNetTime
DotNetTime UTCTime
d)
             _      -> String -> Parser DotNetTime
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "could not parse .NET time"
    {-# INLINE parseJSON #-}

instance ToJSON ZonedTime where
    toJSON :: ZonedTime -> Value
toJSON t :: 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 = "%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
          | 0 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== TimeZone -> Int
timeZoneMinutes (ZonedTime -> TimeZone
zonedTimeZone ZonedTime
t) = "Z"
          | Bool
otherwise = "%z"

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

instance FromJSON ZonedTime where
    parseJSON :: Value -> Parser ZonedTime
parseJSON (String t :: Text
t) =
      [String] -> Parser ZonedTime
tryFormats [String]
alternateFormats
      Parser ZonedTime -> Parser ZonedTime -> Parser ZonedTime
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> Parser ZonedTime
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "could not parse ECMA-262 ISO-8601 date"
      where
        tryFormat :: String -> f a
tryFormat f :: 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 d :: a
d -> a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
d
            Nothing -> 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 (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Parser ZonedTime -> Parser ZonedTime -> Parser ZonedTime
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 ["%Y", "%Y-%m", "%F"]
                         ["T%R", "T%T", "T%T%Q", "T%T%QZ", "T%T%Q%z"]

        distributeList :: t a -> [a] -> [a]
distributeList xs :: t a
xs ys :: [a]
ys =
          (a -> [a] -> [a]) -> [a] -> t a -> [a]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\x :: a
x acc :: [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 x :: 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 v :: Value
v = String -> Value -> Parser ZonedTime
forall a. String -> Value -> Parser a
typeMismatch "ZonedTime" Value
v

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