{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Aeson.Extra
-- Copyright   :  (C) 2015 Oleg Grenrus
-- License     :  BSD3
-- Maintainer  :  Oleg Grenrus <oleg.grenrus@iki.fi>
--
-- More or less useful newtypes for writing 'FromJSON' & 'ToJSON' instances
module Data.Aeson.Extra (
  -- * Generic maps
  M(..),
  FromJSONKey(..),
  parseIntegralJSONKey,
  FromJSONMap(..),
  ToJSONKey(..),
  ToJSONMap(..),
#if MIN_VERSION_base(4,7,0)
  -- * Symbol tag
  SymTag(..),
  -- * Singleton object
  SingObject(..),
  mkSingObject,
  getSingObject,
#endif
  -- * CollapsedList
  CollapsedList(..),
  getCollapsedList,
  parseCollapsedList,
  -- * UTCTime
  U(..),
  Z(..),
  -- * Re-exports
  module Data.Aeson.Compat,
  ) where

#if !MIN_VERSION_base(4,8,0)
import           Data.Foldable (Foldable)
import           Data.Traversable (Traversable, traverse)
#endif

import           Control.Applicative
import           Data.Monoid
import           Data.Aeson.Compat
import           Data.Aeson.Types hiding ((.:?))
import qualified Data.Foldable as Foldable
import qualified Data.HashMap.Strict as H
import           Data.Hashable (Hashable)
import qualified Data.Map as Map
import           Data.Text as T
import qualified Data.Text.Lazy as TL
import           Data.Time (UTCTime, ZonedTime)
import qualified Data.Text.Read as T

#if MIN_VERSION_base(4,7,0)
import           Data.Proxy
import           GHC.TypeLits
#endif

#if !MIN_VERSION_aeson (0,10,0)
import qualified Data.Aeson.Extra.Time as ExtraTime
#endif

-- | A wrapper type to parse arbitrary maps
--
-- > λ > decode "{\"1\": 1, \"2\": 2}" :: Maybe (M (H.HashMap Int Int))
-- > Just (M {getMap = fromList [(1,1),(2,2)]})
newtype M a = M { getMap :: a }
  deriving (Eq, Ord, Show, Read, Functor, Foldable, Traversable)

class FromJSONKey a where
  parseJSONKey :: Text -> Parser a

instance FromJSONKey Text where parseJSONKey = pure
instance FromJSONKey TL.Text where parseJSONKey = pure . TL.fromStrict
instance FromJSONKey String where parseJSONKey = pure . T.unpack
instance FromJSONKey Int where parseJSONKey = parseIntegralJSONKey
instance FromJSONKey Integer where parseJSONKey = parseIntegralJSONKey

parseIntegralJSONKey :: Integral a => Text -> Parser a
parseIntegralJSONKey t = case (T.signed T.decimal) t of
  Right (v, left) | T.null left  -> pure v
                  | otherwise    -> fail $ "Garbage left: " <> T.unpack left
  Left err                       -> fail err

class FromJSONMap m k v | m -> k v where
  parseJSONMap :: H.HashMap Text Value -> Parser m

instance (Eq k, Hashable k, FromJSONKey k, FromJSON v) => FromJSONMap (H.HashMap k v) k v where
  parseJSONMap = fmap H.fromList . traverse f . H.toList
    where f (k, v) = (,) <$> parseJSONKey k <*> parseJSON v

instance (Ord k, FromJSONKey k, FromJSON v) => FromJSONMap (Map.Map k v) k v where
  parseJSONMap = fmap Map.fromList . traverse f . H.toList
    where f (k, v) = (,) <$> parseJSONKey k <*> parseJSON v

instance (FromJSONMap m k v) => FromJSON (M m) where
  parseJSON v = M <$> withObject "Map" parseJSONMap v


class ToJSONKey a where
  toJSONKey :: a -> Text

instance ToJSONKey Text where toJSONKey = id
instance ToJSONKey TL.Text where toJSONKey = TL.toStrict
instance ToJSONKey String where toJSONKey = T.pack
instance ToJSONKey Int where toJSONKey = T.pack . show
instance ToJSONKey Integer where toJSONKey = T.pack . show

class ToJSONMap m k v | m -> k v where
  toJSONMap :: m -> H.HashMap Text Value

instance (ToJSONKey k, ToJSON v) => ToJSONMap (H.HashMap k v) k v where
  toJSONMap = H.fromList . fmap f . H.toList
    where f (k, v) = (toJSONKey k, toJSON v)

instance (ToJSONKey k, ToJSON v) => ToJSONMap (Map.Map k v) k v where
  toJSONMap = H.fromList . fmap f . Map.toList
    where f (k, v) = (toJSONKey k, toJSON v)

instance (ToJSONMap m k v) => ToJSON (M m) where
  toJSON (M m) = Object (toJSONMap m)

#if MIN_VERSION_base(4,7,0)
-- | Singleton string encoded and decoded as ifself.
--
-- > λ> encode (SymTag :: SymTag "foobar")
-- > "\"foobar\""
--
-- > decode "\"foobar\"" :: Maybe (SymTag "foobar")
-- > Just SymTag
--
-- > decode "\"foobar\"" :: Maybe (SymTag "barfoo")
-- > Nothing
--
-- /Available with: base >=4.7/
data SymTag (s :: Symbol) = SymTag
  deriving (Eq, Ord, Show, Read, Enum, Bounded)

instance KnownSymbol s => FromJSON (SymTag s) where
  parseJSON (String t)
    | T.unpack t == symbolVal (Proxy :: Proxy s) = pure SymTag
  parseJSON v = typeMismatch ("SymTag " ++ show (symbolVal (Proxy :: Proxy s))) v

instance KnownSymbol s => ToJSON (SymTag s) where
#if MIN_VERSION_aeson (0,10,0)
  toEncoding _ = toEncoding (symbolVal (Proxy :: Proxy s))
#endif
  toJSON _ = toJSON (symbolVal (Proxy :: Proxy s))


-- | Singleton value object
--
-- > λ > decode "{\"value\": 42 }" :: Maybe (SingObject "value" Int)
-- > Just (SingObject 42)
--
-- > λ > encode (SingObject 42 :: SingObject "value" Int)
-- > "{\"value\":42}"
--
-- /Available with: base >=4.7/
newtype SingObject (s ::Symbol) a = SingObject a
  deriving (Eq, Ord, Show, Read, Functor, Foldable, Traversable)

mkSingObject :: Proxy s -> a -> SingObject s a
mkSingObject _ = SingObject

getSingObject :: Proxy s -> SingObject s a -> a
getSingObject _ (SingObject x) = x

instance (KnownSymbol s, FromJSON a) => FromJSON (SingObject s a) where
  parseJSON = withObject ("SingObject "<> show key) $ \obj ->
    SingObject <$> obj .: T.pack key
    where key = symbolVal (Proxy :: Proxy s)

instance (KnownSymbol s, ToJSON a) => ToJSON (SingObject s a) where
#if MIN_VERSION_aeson(0,10,0)
  toEncoding (SingObject x) = pairs (T.pack key .= x)
    where key = symbolVal (Proxy :: Proxy s)
#endif
  toJSON (SingObject x) = object [T.pack key .= x]
    where key = symbolVal (Proxy :: Proxy s)
#endif


-- | Collapsed list, singleton is represented as the value itself in JSON encoding.
--
-- > λ > decode "null" :: Maybe (CollapsedList [Int] Int)
-- > Just (CollapsedList [])
-- > λ > decode "42" :: Maybe (CollapsedList [Int] Int)
-- > Just (CollapsedList [42])
-- > λ > decode "[1, 2, 3]" :: Maybe (CollapsedList [Int] Int)
-- > Just (CollapsedList [1,2,3])
--
-- > λ > encode (CollapsedList ([] :: [Int]))
-- > "null"
-- > λ > encode (CollapsedList ([42] :: [Int]))
-- > "42"
-- > λ > encode (CollapsedList ([1, 2, 3] :: [Int]))
-- > "[1,2,3]"
--
-- Documentation rely on @f@ 'Alternative' instance behaving like lists'.
newtype CollapsedList f a = CollapsedList (f a)
  deriving (Eq, Ord, Show, Read, Functor, Foldable, Traversable)

getCollapsedList :: CollapsedList f a -> f a
getCollapsedList (CollapsedList l) = l

instance (FromJSON a, FromJSON (f a), Alternative f) => FromJSON (CollapsedList f a) where
  parseJSON Null         = pure (CollapsedList Control.Applicative.empty)
  parseJSON v@(Array _)  = CollapsedList <$> parseJSON v
  parseJSON v            = CollapsedList . pure <$> parseJSON v

instance (ToJSON a, ToJSON (f a), Foldable f) => ToJSON (CollapsedList f a) where
#if MIN_VERSION_aeson (0,10,0)
  toEncoding (CollapsedList l) =
    case Foldable.toList l of
      []   -> toEncoding Null
      [x]  -> toEncoding x
      _    -> toEncoding l
#endif
  toJSON (CollapsedList l) =
    case Foldable.toList l of
      []   -> toJSON Null
      [x]  -> toJSON x
      _    -> toJSON l

-- | Parses possibly collapsed array value from the object's field.
--
-- > λ > newtype V = V [Int] deriving (Show)
-- > λ > instance FromJSON V where parseJSON = withObject "V" $ \obj -> V <$> parseCollapsedList obj "value"
-- > λ > decode "{}" :: Maybe V
-- > Just (V [])
-- > λ > decode "{\"value\": null}" :: Maybe V
-- > Just (V [])
-- > λ > decode "{\"value\": 42}" :: Maybe V
-- > Just (V [42])
-- > λ > decode "{\"value\": [1, 2, 3, 4]}" :: Maybe V
-- > Just (V [1,2,3,4])
parseCollapsedList :: (FromJSON a, FromJSON (f a), Alternative f) => Object -> Text -> Parser (f a)
parseCollapsedList obj key =
  case H.lookup key obj of
    Nothing   -> pure Control.Applicative.empty
#if MIN_VERSION_aeson(0,10,0)
    Just v    -> modifyFailure addKeyName $ (getCollapsedList <$> parseJSON v) -- <?> Key key
  where
    addKeyName = (("failed to parse field " <> T.unpack key <> ": ") <>)
#else
    Just v    -> getCollapsedList <$> parseJSON v
#endif

-- | A type to parse 'UTCTime'
--
-- 'FromJSON' instance accepts for example:
--
-- @
-- 2015-09-07T08:16:40.807Z
-- 2015-09-07 11:16:40.807 +03:00
-- @
--
-- Latter format is accepted by @aeson@ staring from version @0.10.0.0@.
--
-- See <https://github.com/bos/aeson/blob/4667ef1029a373cf4510f7deca147c357c6d8947/Data/Aeson/Parser/Time.hs#L150>
--
-- /Since: aeson-extra-0.2.2.0/
newtype U = U { getU :: UTCTime }
  deriving (Eq, Ord, Show, Read)

instance ToJSON U where
  toJSON = toJSON . getU
#if MIN_VERSION_aeson (0,10,0)
  toEncoding = toEncoding . getU
#endif

instance FromJSON U where
#if MIN_VERSION_aeson (0,10,0)
  parseJSON = fmap U . parseJSON
#else
  parseJSON = withText "UTCTime" (fmap U . ExtraTime.run ExtraTime.utcTime)
#endif

-- | A type to parse 'ZonedTime'
--
-- /Since: aeson-extra-0.2.2.0/
newtype Z = Z { getZ :: ZonedTime }
  deriving (Show, Read)

instance ToJSON Z where
  toJSON = toJSON . getZ
#if MIN_VERSION_aeson (0,10,0)
  toEncoding = toEncoding . getZ
#endif

instance FromJSON Z where
#if MIN_VERSION_aeson (0,10,0)
  parseJSON = fmap Z . parseJSON
#else
  parseJSON = withText "ZonedTime" (fmap Z . ExtraTime.run ExtraTime.zonedTime)
#endif