{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}

{-# LANGUAGE AllowAmbiguousTypes  #-}
{-# LANGUAGE FlexibleContexts     #-}
{-# LANGUAGE UndecidableInstances #-}

{- | Options used to derive FromJSON/ToJSON instance. These options generally
comply to @elm-street@ rules regarding names.
-}

module Elm.Aeson
       ( elmStreetParseJson
       , elmStreetToJson
       , elmStreetJsonOptions

       , ElmStreet (..)
       ) where

import Data.Aeson (FromJSON (..), GFromJSON, GToJSON, Options (..), ToJSON (..), Value, Zero,
                   defaultOptions, genericParseJSON, genericToJSON)
import Data.Aeson.Types (Parser)
import GHC.Generics (Generic, Rep)
import Type.Reflection (Typeable, typeRep)

import Elm.Ast (TypeName (..))
import Elm.Generic (Elm (..), GenericElmDefinition (..), HasLessThanEightUnnamedFields,
                    HasNoNamedSum, HasNoTypeVars, stripTypeNamePrefix)

import qualified Data.Text as T
import qualified GHC.Generics as Generic (from)


{- | Allows to create 'Data.Aeson.FromJSON' instance that strips the supported
by @elm-street@ data type name prefix from every field..

__Example:__

With the following @JSON@

@
{ \"name\": \"John\"
, \"age\": 42
}
@

it is decoded it the following way for each of the specified types:

+-------------------------------+--------------------------+
| Haskell data type             | Parsed type              |
+===============================+==========================+
| @                             | @                        |
| data User = User              | User                     |
| \   { userName :: String      |    { userName = \"John\" |
| \   , userAge  :: Int         |    , userAge  = 42       |
| \   }                         |    }                     |
| @                             | @                        |
+-------------------------------+--------------------------+
|                               |                          |
| @                             | @                        |
| data LongUser = LongUser      | LongUser                 |
|    { luName :: String         |    { luName = \"John\"   |
|    , luAge  :: Int            |    , luAge  = 42         |
|    }                          |    }                     |
| @                             | @                        |
+-------------------------------+--------------------------+
| @                             | @                        |
| data SimpleUser = SimpleUser  | SimpleUser               |
|    { name :: String           |    { name = \"John\"     |
|    , age  :: Int              |    , age  = 42           |
|    }                          |    }                     |
| @                             | @                        |
+-------------------------------+--------------------------+

>>> data User = User { userName :: String, userAge :: Int } deriving (Generic, Show)
>>> instance FromJSON User where parseJSON = elmStreetParseJson
>>> decode @User "{ \"name\": \"John\", \"age\": 42 }"
Just (User {userName = "John", userAge = 42})


>>> data VeryLongType = VeryLongType { vltName :: String, vltAge :: Int } deriving (Generic, Show)
>>> instance FromJSON VeryLongType where parseJSON = elmStreetParseJson
>>> decode @VeryLongType "{ \"name\": \"John\", \"age\": 42 }"
Just (VeryLongType {vltName = "John", vltAge = 42})

-}
elmStreetParseJson
    :: forall a .
       (Typeable a, Generic a, GFromJSON Zero (Rep a))
    => Value
    -> Parser a
elmStreetParseJson :: Value -> Parser a
elmStreetParseJson = Options -> Value -> Parser a
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON (Typeable a => Options
forall a. Typeable a => Options
elmStreetJsonOptions @a)

{- | Allows to create 'Data.Aeson.ToJSON' instance that strips the supported by
@elm-street@ data type name prefix from every field.

>>> data User = User { userName :: String, userAge :: Int } deriving (Generic, Show)
>>> instance ToJSON User where toJSON = elmStreetToJson
>>> encode $ User { userName = "John", userAge = 42 }
"{\"age\":42,\"name\":\"John\"}"

>>> data VeryLongType = VeryLongType { vltName :: String, vltAge :: Int } deriving (Generic, Show)
>>> instance ToJSON VeryLongType where toJSON = elmStreetToJson
>>> encode $ VeryLongType {vltName = "John", vltAge = 42}
"{\"age\":42,\"name\":\"John\"}"

>>> data User = User { name :: String, age :: Int } deriving (Generic, Show)
>>> instance ToJSON User where toJSON = elmStreetToJson
>>> encode $ User { name = "John", age = 42 }
"{\"age\":42,\"name\":\"John\"}"
-}
elmStreetToJson
    :: forall a .
       (Typeable a, Generic a, GToJSON Zero (Rep a))
    => a
    -> Value
elmStreetToJson :: a -> Value
elmStreetToJson = Options -> a -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON (Typeable a => Options
forall a. Typeable a => Options
elmStreetJsonOptions @a)

{- | Options to strip type name from the field names.

+----------------+----------------+---------------------+
| Data type name | Field name     | Stripped field name |
+================+================+=====================+
| @User@         | @userName@     | @name@              |
+----------------+----------------+---------------------+
| @AaaBbbCcc@    | @abcFieldName@ | @fieldName@         |
+----------------+----------------+---------------------+
| @Foo@          | @field@        | @field@             |
+----------------+----------------+---------------------+
| @Field@        | @field@        | @field@             |
+----------------+----------------+---------------------+

-}
elmStreetJsonOptions :: forall a . Typeable a => Options
elmStreetJsonOptions :: Options
elmStreetJsonOptions = Options
defaultOptions
    { fieldLabelModifier :: String -> String
fieldLabelModifier = Text -> String
T.unpack (Text -> String) -> (String -> Text) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeName -> Text -> Text
stripTypeNamePrefix TypeName
typeName (Text -> Text) -> (String -> Text) -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack
    , tagSingleConstructors :: Bool
tagSingleConstructors = Bool
True
    }
  where
    typeName :: TypeName
    typeName :: TypeName
typeName = Text -> TypeName
TypeName (Text -> TypeName) -> Text -> TypeName
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ TypeRep a -> String
forall a. Show a => a -> String
show (TypeRep a -> String) -> TypeRep a -> String
forall a b. (a -> b) -> a -> b
$ Typeable a => TypeRep a
forall k (a :: k). Typeable a => TypeRep a
typeRep @a


{- | Newtype for reusing in @DerivingVia@.

In order to use it with your type @MyType@ add the following deriving to your type:

@
    __deriving__ (Elm, ToJSON, FromJSON) __via__ ElmStreet MyType
@
-}
newtype ElmStreet a = ElmStreet
    { ElmStreet a -> a
unElmStreet :: a
    }

instance ( HasNoTypeVars a
         , HasLessThanEightUnnamedFields a
         , HasNoNamedSum a
         , Generic a
         , GenericElmDefinition (Rep a)
         ) => Elm (ElmStreet a) where
    toElmDefinition :: Proxy (ElmStreet a) -> ElmDefinition
toElmDefinition Proxy (ElmStreet a)
_ = Rep a Any -> ElmDefinition
forall k (f :: k -> *) (a :: k).
GenericElmDefinition f =>
f a -> ElmDefinition
genericToElmDefinition
        (Rep a Any -> ElmDefinition) -> Rep a Any -> ElmDefinition
forall a b. (a -> b) -> a -> b
$ a -> Rep a Any
forall a x. Generic a => a -> Rep a x
Generic.from (String -> a
forall a. HasCallStack => String -> a
error String
"Proxy for generic elm was evaluated" :: a)

instance (Typeable a, Generic a, GToJSON Zero (Rep a)) => ToJSON (ElmStreet a) where
    toJSON :: ElmStreet a -> Value
toJSON = a -> Value
forall a.
(Typeable a, Generic a, GToJSON Zero (Rep a)) =>
a -> Value
elmStreetToJson (a -> Value) -> (ElmStreet a -> a) -> ElmStreet a -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ElmStreet a -> a
forall a. ElmStreet a -> a
unElmStreet

instance (Typeable a, Generic a, GFromJSON Zero (Rep a)) => FromJSON (ElmStreet a) where
    parseJSON :: Value -> Parser (ElmStreet a)
parseJSON = (a -> ElmStreet a) -> Parser a -> Parser (ElmStreet a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> ElmStreet a
forall a. a -> ElmStreet a
ElmStreet (Parser a -> Parser (ElmStreet a))
-> (Value -> Parser a) -> Value -> Parser (ElmStreet a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Parser a
forall a.
(Typeable a, Generic a, GFromJSON Zero (Rep a)) =>
Value -> Parser a
elmStreetParseJson