    {-# 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 #-}