{-# LANGUAGE UndecidableInstances #-}
-- |
-- Module : Data.Aeson.DefaultField
-- License     : BSD-style
--
-- Maintainer  : palkovsky.ondrej@gmail.com
-- Stability   : experimental
-- Portability : portable
--
-- Type-level default fields for aeson Generic FromJSON parser 
--

module Data.Aeson.DefaultField (
  -- * How to use this library
  -- $use

  -- * How to extend the library
  -- $extend

  -- * Caveats
  -- $caveats

  -- * Main field types and functions
    DefaultField
  , ParseStage(Final)
  , parseWithDefaults
  -- * Different basic types
  , DefInt(..)
  , DefNegativeInt(..)
  , DefText(..)
  , DefString(..)
  , DefBool(..)
  , DefDefault(..)
  -- * Support for newtype default constants
  , DefaultConstant(..)
  , DefDefaultConstant(..)
) where

import GHC.TypeLits (Nat, KnownNat, Symbol, KnownSymbol, natVal, symbolVal)
import Data.Aeson (FromJSON(..), genericParseJSON)
import qualified Data.Aeson as AE
import qualified Data.Text as T
import GHC.Generics
import Data.Kind (Type)
import Data.Coerce (Coercible, coerce)
import Data.Aeson.Types (Parser)
import Data.Proxy (Proxy(..))
import Data.String (fromString)
import Data.Default (Default (def))

-- | Boolean default field
newtype DefBool (a :: Bool) = DefBool Bool
  deriving ((forall x. DefBool a -> Rep (DefBool a) x)
-> (forall x. Rep (DefBool a) x -> DefBool a)
-> Generic (DefBool a)
forall (a :: Bool) x. Rep (DefBool a) x -> DefBool a
forall (a :: Bool) x. DefBool a -> Rep (DefBool a) x
forall x. Rep (DefBool a) x -> DefBool a
forall x. DefBool a -> Rep (DefBool a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall (a :: Bool) x. DefBool a -> Rep (DefBool a) x
from :: forall x. DefBool a -> Rep (DefBool a) x
$cto :: forall (a :: Bool) x. Rep (DefBool a) x -> DefBool a
to :: forall x. Rep (DefBool a) x -> DefBool a
Generic)
instance FromJSON (DefBool True) where
  omittedField :: Maybe (DefBool 'True)
omittedField = DefBool 'True -> Maybe (DefBool 'True)
forall a. a -> Maybe a
Just (Bool -> DefBool 'True
forall (a :: Bool). Bool -> DefBool a
DefBool Bool
True)
  parseJSON :: Value -> Parser (DefBool 'True)
parseJSON Value
v = Bool -> DefBool 'True
forall (a :: Bool). Bool -> DefBool a
DefBool (Bool -> DefBool 'True) -> Parser Bool -> Parser (DefBool 'True)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser Bool
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v
instance FromJSON (DefBool False) where
  omittedField :: Maybe (DefBool 'False)
omittedField = DefBool 'False -> Maybe (DefBool 'False)
forall a. a -> Maybe a
Just (Bool -> DefBool 'False
forall (a :: Bool). Bool -> DefBool a
DefBool Bool
False)
  parseJSON :: Value -> Parser (DefBool 'False)
parseJSON Value
v = Bool -> DefBool 'False
forall (a :: Bool). Bool -> DefBool a
DefBool (Bool -> DefBool 'False) -> Parser Bool -> Parser (DefBool 'False)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser Bool
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v

-- | Positive Int default field (only positive numbers are supported as type parameters)
newtype DefInt (num :: Nat) = DefInt Int
  deriving ((forall x. DefInt num -> Rep (DefInt num) x)
-> (forall x. Rep (DefInt num) x -> DefInt num)
-> Generic (DefInt num)
forall (num :: Nat) x. Rep (DefInt num) x -> DefInt num
forall (num :: Nat) x. DefInt num -> Rep (DefInt num) x
forall x. Rep (DefInt num) x -> DefInt num
forall x. DefInt num -> Rep (DefInt num) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall (num :: Nat) x. DefInt num -> Rep (DefInt num) x
from :: forall x. DefInt num -> Rep (DefInt num) x
$cto :: forall (num :: Nat) x. Rep (DefInt num) x -> DefInt num
to :: forall x. Rep (DefInt num) x -> DefInt num
Generic)
instance KnownNat num => FromJSON (DefInt num) where
  omittedField :: Maybe (DefInt num)
omittedField = DefInt num -> Maybe (DefInt num)
forall a. a -> Maybe a
Just (Int -> DefInt num
forall (num :: Nat). Int -> DefInt num
DefInt (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Int) -> Integer -> Int
forall a b. (a -> b) -> a -> b
$ Proxy num -> Integer
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (forall (t :: Nat). Proxy t
forall {k} (t :: k). Proxy t
Proxy @num)))
  parseJSON :: Value -> Parser (DefInt num)
parseJSON Value
v = Int -> DefInt num
forall (num :: Nat). Int -> DefInt num
DefInt (Int -> DefInt num) -> Parser Int -> Parser (DefInt num)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser Int
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v

-- | Negative Int default field
newtype DefNegativeInt (num :: Nat) = DefNegativeInt Int
  deriving ((forall x. DefNegativeInt num -> Rep (DefNegativeInt num) x)
-> (forall x. Rep (DefNegativeInt num) x -> DefNegativeInt num)
-> Generic (DefNegativeInt num)
forall (num :: Nat) x.
Rep (DefNegativeInt num) x -> DefNegativeInt num
forall (num :: Nat) x.
DefNegativeInt num -> Rep (DefNegativeInt num) x
forall x. Rep (DefNegativeInt num) x -> DefNegativeInt num
forall x. DefNegativeInt num -> Rep (DefNegativeInt num) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall (num :: Nat) x.
DefNegativeInt num -> Rep (DefNegativeInt num) x
from :: forall x. DefNegativeInt num -> Rep (DefNegativeInt num) x
$cto :: forall (num :: Nat) x.
Rep (DefNegativeInt num) x -> DefNegativeInt num
to :: forall x. Rep (DefNegativeInt num) x -> DefNegativeInt num
Generic)
instance KnownNat num => FromJSON (DefNegativeInt num) where
  omittedField :: Maybe (DefNegativeInt num)
omittedField = DefNegativeInt num -> Maybe (DefNegativeInt num)
forall a. a -> Maybe a
Just (Int -> DefNegativeInt num
forall (num :: Nat). Int -> DefNegativeInt num
DefNegativeInt (Int -> Int
forall a. Num a => a -> a
negate (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Int) -> Integer -> Int
forall a b. (a -> b) -> a -> b
$ Proxy num -> Integer
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (forall (t :: Nat). Proxy t
forall {k} (t :: k). Proxy t
Proxy @num)))
  parseJSON :: Value -> Parser (DefNegativeInt num)
parseJSON Value
v = Int -> DefNegativeInt num
forall (num :: Nat). Int -> DefNegativeInt num
DefNegativeInt (Int -> DefNegativeInt num)
-> Parser Int -> Parser (DefNegativeInt num)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser Int
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v

-- | Text default field
newtype DefText (x :: Symbol) = DefText T.Text
  deriving ((forall x. DefText x -> Rep (DefText x) x)
-> (forall x. Rep (DefText x) x -> DefText x)
-> Generic (DefText x)
forall x. Rep (DefText x) x -> DefText x
forall x. DefText x -> Rep (DefText x) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (x :: Symbol) x. Rep (DefText x) x -> DefText x
forall (x :: Symbol) x. DefText x -> Rep (DefText x) x
$cfrom :: forall (x :: Symbol) x. DefText x -> Rep (DefText x) x
from :: forall x. DefText x -> Rep (DefText x) x
$cto :: forall (x :: Symbol) x. Rep (DefText x) x -> DefText x
to :: forall x. Rep (DefText x) x -> DefText x
Generic)
instance KnownSymbol sym => FromJSON (DefText sym) where
  omittedField :: Maybe (DefText sym)
omittedField = DefText sym -> Maybe (DefText sym)
forall a. a -> Maybe a
Just (Text -> DefText sym
forall (x :: Symbol). Text -> DefText x
DefText (String -> Text
forall a. IsString a => String -> a
fromString (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Proxy sym -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @sym)))
  parseJSON :: Value -> Parser (DefText sym)
parseJSON Value
v = Text -> DefText sym
forall (x :: Symbol). Text -> DefText x
DefText (Text -> DefText sym) -> Parser Text -> Parser (DefText sym)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser Text
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v

-- | String default field
newtype DefString (x :: Symbol) = DefString String
  deriving ((forall x. DefString x -> Rep (DefString x) x)
-> (forall x. Rep (DefString x) x -> DefString x)
-> Generic (DefString x)
forall x. Rep (DefString x) x -> DefString x
forall x. DefString x -> Rep (DefString x) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (x :: Symbol) x. Rep (DefString x) x -> DefString x
forall (x :: Symbol) x. DefString x -> Rep (DefString x) x
$cfrom :: forall (x :: Symbol) x. DefString x -> Rep (DefString x) x
from :: forall x. DefString x -> Rep (DefString x) x
$cto :: forall (x :: Symbol) x. Rep (DefString x) x -> DefString x
to :: forall x. Rep (DefString x) x -> DefString x
Generic)
instance KnownSymbol sym => FromJSON (DefString sym) where
  omittedField :: Maybe (DefString sym)
omittedField = DefString sym -> Maybe (DefString sym)
forall a. a -> Maybe a
Just (String -> DefString sym
forall (x :: Symbol). String -> DefString x
DefString (Proxy sym -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @sym)))
  parseJSON :: Value -> Parser (DefString sym)
parseJSON Value
v = String -> DefString sym
forall (x :: Symbol). String -> DefString x
DefString (String -> DefString sym)
-> Parser String -> Parser (DefString sym)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser String
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v

-- | Default field using the "Default" class
newtype DefDefault a = DefDefault a
  deriving ((forall x. DefDefault a -> Rep (DefDefault a) x)
-> (forall x. Rep (DefDefault a) x -> DefDefault a)
-> Generic (DefDefault a)
forall x. Rep (DefDefault a) x -> DefDefault a
forall x. DefDefault a -> Rep (DefDefault a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (DefDefault a) x -> DefDefault a
forall a x. DefDefault a -> Rep (DefDefault a) x
$cfrom :: forall a x. DefDefault a -> Rep (DefDefault a) x
from :: forall x. DefDefault a -> Rep (DefDefault a) x
$cto :: forall a x. Rep (DefDefault a) x -> DefDefault a
to :: forall x. Rep (DefDefault a) x -> DefDefault a
Generic)
instance (FromJSON a, Default a) => FromJSON (DefDefault a) where
  omittedField :: Maybe (DefDefault a)
omittedField = DefDefault a -> Maybe (DefDefault a)
forall a. a -> Maybe a
Just (a -> DefDefault a
forall a. a -> DefDefault a
DefDefault a
forall a. Default a => a
def)
  parseJSON :: Value -> Parser (DefDefault a)
parseJSON Value
v = a -> DefDefault a
forall a. a -> DefDefault a
DefDefault (a -> DefDefault a) -> Parser a -> Parser (DefDefault a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser a
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v


-- | Default class for 'DefDefaultConstant' field configuration
class (Generic a, GNewtype (Rep a)) => DefaultConstant a where
  defValue :: Proxy a -> EmbeddedType (Rep a)

-- | Use 'DefaultConstant' type as a default value for a field.
--
-- E.g. you cannot create a direct settings for real numbers; however, you can do this:
--
-- > newtype Pi = Pi Double deriving Generic
-- > instance DefaultConstant Pi where
-- >   defValue _ = 3.141592654
-- >
-- > data MyObjectT d = MyObject {
-- >   phaseAngle :: DefaultField d (DefDefaultConstant Pi)
-- > } deriving Generic
newtype DefDefaultConstant a = DefDefaultConstant (EmbeddedType (Rep a))
  deriving ((forall x. DefDefaultConstant a -> Rep (DefDefaultConstant a) x)
-> (forall x. Rep (DefDefaultConstant a) x -> DefDefaultConstant a)
-> Generic (DefDefaultConstant a)
forall x. Rep (DefDefaultConstant a) x -> DefDefaultConstant a
forall x. DefDefaultConstant a -> Rep (DefDefaultConstant a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (DefDefaultConstant a) x -> DefDefaultConstant a
forall a x. DefDefaultConstant a -> Rep (DefDefaultConstant a) x
$cfrom :: forall a x. DefDefaultConstant a -> Rep (DefDefaultConstant a) x
from :: forall x. DefDefaultConstant a -> Rep (DefDefaultConstant a) x
$cto :: forall a x. Rep (DefDefaultConstant a) x -> DefDefaultConstant a
to :: forall x. Rep (DefDefaultConstant a) x -> DefDefaultConstant a
Generic)
instance (DefaultConstant a, FromJSON (EmbeddedType (Rep a))) => FromJSON (DefDefaultConstant a) where
  omittedField :: Maybe (DefDefaultConstant a)
omittedField = DefDefaultConstant a -> Maybe (DefDefaultConstant a)
forall a. a -> Maybe a
Just (EmbeddedType (Rep a) -> DefDefaultConstant a
forall a. EmbeddedType (Rep a) -> DefDefaultConstant a
DefDefaultConstant (EmbeddedType (Rep a) -> DefDefaultConstant a)
-> EmbeddedType (Rep a) -> DefDefaultConstant a
forall a b. (a -> b) -> a -> b
$ Proxy a -> EmbeddedType (Rep a)
forall a. DefaultConstant a => Proxy a -> EmbeddedType (Rep a)
defValue (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a))
  parseJSON :: Value -> Parser (DefDefaultConstant a)
parseJSON Value
v = EmbeddedType (Rep a) -> DefDefaultConstant a
forall a. EmbeddedType (Rep a) -> DefDefaultConstant a
DefDefaultConstant (EmbeddedType (Rep a) -> DefDefaultConstant a)
-> Parser (EmbeddedType (Rep a)) -> Parser (DefDefaultConstant a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser (EmbeddedType (Rep a))
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v

-- | Kind for separating parsing with defaults and the final type
data ParseStage = 
    InsertDefaults  -- ^ Use this type to instantiate the intermediate data type for parsing defaults
  | Final -- ^ Use this type to instantiate the final data type (e.g. using the type alias)

-- | Higher-kinded-type that either instantiates the field to a newtype that
-- decodes the default value if not present; or instantiates to the type
-- embedded in the newtype parameter
type family DefaultField (m :: ParseStage) a where
  DefaultField InsertDefaults a = a
  DefaultField Final a = EmbeddedType (Rep a)

-- | Copied from newtype-generics package; this way we get the type inside the newtype
class GNewtype n where
  type EmbeddedType n :: Type -- ^ Type function to retrieve the type embedded in the newtype
instance GNewtype (D1 d (C1 c (S1 s (K1 i a)))) where
  type EmbeddedType (D1 d (C1 c (S1 s (K1 i a)))) = a

-- | 'genericParseJSON' drop-in replacement
parseWithDefaults :: forall (o :: ParseStage -> Type).
    (AE.GFromJSON AE.Zero (Rep (o InsertDefaults))
    , Generic (o InsertDefaults), Generic (o Final)
    , Coercible (Rep (o InsertDefaults)) (Rep (o Final))
    ) 
    => AE.Options -> AE.Value -> Parser (o Final)
parseWithDefaults :: forall (o :: ParseStage -> *).
(GFromJSON Zero (Rep (o 'InsertDefaults)),
 Generic (o 'InsertDefaults), Generic (o 'Final),
 Coercible (Rep (o 'InsertDefaults)) (Rep (o 'Final))) =>
Options -> Value -> Parser (o 'Final)
parseWithDefaults Options
opts Value
v =
    o 'InsertDefaults -> o 'Final
forall {a} {c}.
(Coercible (Rep a) (Rep c), Generic c, Generic a) =>
a -> c
gcoerce (o 'InsertDefaults -> o 'Final)
-> Parser (o 'InsertDefaults) -> Parser (o 'Final)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON @(o InsertDefaults) Options
opts Value
v
  where
    -- Taken from generic-data
    gcoerce :: a -> c
gcoerce = Rep c Any -> c
forall a x. Generic a => Rep a x -> a
forall x. Rep c x -> c
to (Rep c Any -> c) -> (a -> Rep c Any) -> a -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rep a Any -> Rep c Any
forall {k} (f :: k -> *) (g :: k -> *) (x :: k).
Coercible f g =>
f x -> g x
coerce1 (Rep a Any -> Rep c Any) -> (a -> Rep a Any) -> a -> Rep c Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Rep a Any
forall x. a -> Rep a x
forall a x. Generic a => a -> Rep a x
from
    coerce1 :: Coercible f g => f x -> g x
    coerce1 :: forall {k} (f :: k -> *) (g :: k -> *) (x :: k).
Coercible f g =>
f x -> g x
coerce1 = f x -> g x
forall a b. Coercible a b => a -> b
coerce

-- $use
--
-- @
-- import Data.Aeson ( FromJSON(parseJSON), decode )
-- import Data.Default ( Default(..) )
-- import GHC.Generics (Generic)
-- import qualified Data.Text as T
-- import qualified Data.Aeson as AE
-- import Data.Aeson.DefaultField
-- 
-- -- Define some custom datatype for json data
-- data Color = Red | Green | Blue deriving (Generic, 'FromJSON', Show)
-- 
-- -- We may want a default instance for later use with 'DefDefault'
-- instance 'Default' Color where
--   def = Red
-- 
-- -- Alternatively, we may create a separate default type that would be coerced back
-- -- to Color with 'DefDefaultConstant'. This allows for different default values
-- -- with the same type for different fields.
-- newtype BlueDefault = BlueDefault Color deriving Generic
-- instance 'DefaultConstant' BlueDefault where
--   defValue _ = Blue
-- 
-- -- Simply create the data object we want to parse from the file; add a type parameter
-- -- so that we can use the type family magic to create 2 different type representations.
-- -- Normal fields act normally. Use 'DefaultField' with the appropriate settings
-- -- to configure the parsing of the missing fields. Null fields are NOT replaced
-- -- with the default value; only missing fields are.
-- data ConfigFileT d = ConfigFile {
--     defaultEnabled :: 'DefaultField' d ('DefBool' True)
--   , defaultDisabled :: 'DefaultField' d ('DefBool' False)
--   , defaultText :: 'DefaultField' d ('DefText' "default text")
--   , defaultInt :: 'DefaultField' d ('DefInt' 42)
--   , defaultNegativeInt :: 'DefaultField' d ('DefNegativeInt' 42)
--   , defaultRed :: 'DefaultField' d ('DefDefault' Color)
--   , defaultBlue :: 'DefaultField' d ('DefDefaultConstant' BlueDefault)
--   , normalField :: T.Text
--   , normalOptional :: Maybe Int
-- } deriving (Generic)
-- 
-- -- Create a type alias so that we can (mostly) handle the type as if nothing special
-- -- was happening under the hood.
-- type ConfigFile = ConfigFileT 'Final'
-- deriving instance Show ConfigFile
-- 
-- -- Create a custom parsing instance for the data object. 
-- instance FromJSON ConfigFile where
--   parseJSON = 'parseWithDefaults' AE.defaultOptions{AE.rejectUnknownFields=True}
--
-- @
-- 
-- >>> AE.decode "{\"defaultDisabled\":true,\"normalField\":\"text\"}" :: Maybe ConfigFile
-- >>> Just (ConfigFile {
--           defaultEnabled = True
--         , defaultDisabled = True
--         , defaultText = "default text"
--         , defaultInt = 42
--         , defaultNegativeInt = -42
--         , defaultRed = Red
--         , defaultBlue = Blue
--         , normalField = "text"
--         , normalOptional = Nothing}
--         )

-- $extend
--
-- The provided 'DefText', 'DefInt', etc. newtypes should provide enough flexibility to configure the missing
-- fields for the objects. If a special type of configuration is needed, a /newtype/
-- based on a final type must be created with 'Generic' and 'FromJSON' instances.
-- See the source code for examples.
--
-- The default newtypes do not replace null value with the default value. You can create your own
-- types that behave differently.
--
-- E.g. a configuration that would use the singletons package is:
--
-- > newtype DefSing (a :: k) = DefSing (Demote k) deriving Generic
-- > instance (SingI a, SingKind k, FromJSON (Demote k)) => FromJSON (DefSing (a :: k)) where
-- >  omittedField = Just $ DefSing $ fromSing (sing @a)
-- >  parseJSON v = DefSing <$> parseJSON v
--
-- The configuration would then be:
--
-- > defaultBool :: DefaultField d (DefSing False)

-- $caveats
--
-- The final step in the parsing is coercing the structure with newtypes (e.g. 'DefBool') to 
-- a structure with the final types (e.g. Bool). Unfortunately, the type families in Haskell 
-- cause the type not to be directly coercible between the intermediate and the 'Final' stage.
-- However, it is possible through the Generic instances.
--
-- This solution probably brings some performance degradation in the sense that the structure
-- must be recreated. Benchmark before use in performance-sensitive situations.