{-# Language DerivingVia #-}
{-# Language DataKinds #-}
{-# Language TemplateHaskell #-}
{-# Language DeriveAnyClass #-}
{-# Language DuplicateRecordFields #-}

module Main where

import Data.Aeson
import Data.Aeson.Deriving
import Data.Foldable (for_)
import Data.Aeson.Deriving.Text.Unsafe
import Data.Text
import GHC.Generics
import Hedgehog
import Hedgehog.Main (defaultMain)

main :: IO ()
main = defaultMain [checkParallel $$(discover)]

type IdiomaticEncoded =
  GenericEncoded '[FieldLabelModifier := '[SnakeCase, DropLowercasePrefix]]

data Dog = Dog
  { dogAgeInDogYears :: Int
  , dogName :: String
  }
  deriving stock (Generic, Show, Eq)
  deriving (ToJSON, FromJSON) via IdiomaticEncoded Dog

once :: Property -> Property
once = withTests 1

prop_fido_encodes_as_expected :: Property
prop_fido_encodes_as_expected = once . property $
  encode (Dog 9 "fido") === "{\"name\":\"fido\",\"age_in_dog_years\":9}"

prop_fido_decodes_as_expected :: Property
prop_fido_decodes_as_expected = once . property $
  tripping (Dog 9 "fido") encode eitherDecode


type UppercaseTypeTagEncoded =
  GenericEncoded
    '[ FieldLabelModifier := '[SnakeCase, DropLowercasePrefix]
    ,  SumEncoding := TaggedObject "type" "contents"
    ,  TagSingleConstructors := 'True
    ,  ConstructorTagModifier := '[Uppercase, SnakeCase]
    ]

data PostArticle = PostArticle
  { articleName :: String
  , articleText :: String
  }
  deriving stock (Generic, Show, Eq)
  deriving (ToJSON, FromJSON) via UppercaseTypeTagEncoded PostArticle

data DeleteArticle = DeleteArticle
  { articleId :: Int
  }
  deriving stock (Generic, Show, Eq)
  deriving (ToJSON, FromJSON) via UppercaseTypeTagEncoded DeleteArticle

data ArticleCommand
  = MkPostArticle PostArticle
  | MkDeleteArticle DeleteArticle
  deriving stock (Generic, Show, Eq)
  deriving (ToJSON, FromJSON) via RecordSumEncoded "type" '[Uppercase, SnakeCase] ArticleCommand

prop_record_sum_encodes_as_expected :: Property
prop_record_sum_encodes_as_expected = once . property $
  encode (MkDeleteArticle $ DeleteArticle 9)
    === "{\"id\":9,\"type\":\"DELETE_ARTICLE\"}"

prop_record_sum_decodes_as_expected :: Property
prop_record_sum_decodes_as_expected = once . property $
  tripping (MkDeleteArticle $ DeleteArticle 9) encode decode


data MyVal
instance KnownJSON MyVal where jsonVal _ = Number 1

data X = X {xval :: Int}
  deriving stock (Generic, Show, Eq)
  deriving (FromJSON, ToJSON) via
    X
      & GenericEncoded '[]
      & WithConstantFields
          '["bar" := "baaz", "quux" := MyVal, "arr" := ["Hilbert","Dirac"]]

prop_WithConstantFields_extra_fields_encode_as_expected :: Property
prop_WithConstantFields_extra_fields_encode_as_expected = once . property $
  encode (X 9)
    === "{\"xval\":9,\"arr\":[\"Hilbert\",\"Dirac\"],\"quux\":1,\"bar\":\"baaz\"}"

prop_WithConstantFields_extra_fields_decode_as_expected :: Property
prop_WithConstantFields_extra_fields_decode_as_expected = once . property $
  tripping (X 9) encode decode

prop_WithConstantFields_extra_fields_required_when_decoding :: Property
prop_WithConstantFields_extra_fields_required_when_decoding = once . property $
  decode @X "{\"xval\":9}" === Nothing

data X2 = X2 {xval :: Int}
  deriving stock (Generic, Show, Eq)
  deriving (FromJSON, ToJSON) via
    WithConstantFieldsOut
      '["bar" := "baaz", "quux" := "axion"]
      (GenericEncoded '[] X2)

prop_WithConstantFieldsOut_encodes_as_expected :: Property
prop_WithConstantFieldsOut_encodes_as_expected = once . property $
  encode (X2 9)
    === "{\"xval\":9,\"quux\":\"axion\",\"bar\":\"baaz\"}"

prop_WithConstantFieldsOut_extra_fields_not_required_when_decoding :: Property
prop_WithConstantFieldsOut_extra_fields_not_required_when_decoding = once . property $
  decode @X2 "{\"xval\":9}" === Just (X2 9)

data X3 = X3 {xval :: Int}
  deriving stock (Generic, Show, Eq)
  deriving (FromJSON, ToJSON) via
    WithConstantFieldsIn
      '["bar" := "baaz", "quux" := "axion"]
      (GenericEncoded '[] X3)

prop_WithConstantFieldsIn_encodes_as_expected :: Property
prop_WithConstantFieldsIn_encodes_as_expected = once . property $
  encode (X3 13)
    === "{\"xval\":13}"

prop_WithConstantFieldsIn_decodes_as_expected :: Property
prop_WithConstantFieldsIn_decodes_as_expected = once . property $
  decode @X3 "{\"xval\":9,\"quux\":\"axion\",\"bar\":\"baaz\"}" === Just (X3 9)

prop_WithConstantFieldsIn_extra_fields_required_when_decoding :: Property
prop_WithConstantFieldsIn_extra_fields_required_when_decoding = once . property $
  decode @X3 "{\"xval\":9}" === Nothing

data Y = Y {yval :: Int}
  deriving stock (Generic, Show, Eq)
  deriving (FromJSON, ToJSON) via
    SingleFieldObject "boop" (GenericEncoded '[] Y)

prop_single_field_objects_encode_as_expected :: Property
prop_single_field_objects_encode_as_expected = once . property $
  encode (Y 7)
    === "{\"boop\":{\"yval\":7}}"

prop_single_field_objects_decode_as_expected :: Property
prop_single_field_objects_decode_as_expected = once . property $
  tripping (Y 7) encode decode

data Z = Z {zval :: String}
  deriving stock (Generic, Show, Eq)
  deriving (FromJSON, ToJSON) via
    RemapTextField "zval" "bad" "good" (GenericEncoded '[] Z)

prop_remapped_text_fields_encode_as_expected :: Property
prop_remapped_text_fields_encode_as_expected = once . property $ do
  encode (Z "bad") === "{\"zval\":\"good\"}"
  encode (Z "cat") === "{\"zval\":\"cat\"}"

prop_remapped_text_fields_decode_as_expected :: Property
prop_remapped_text_fields_decode_as_expected = once . property $ do
  tripping (Z "bad") encode decode
  tripping (Z "cat") encode decode
  Just (Z "bad") === decode "{\"zval\":\"good\"}"
  Just (Z "cat") === decode "{\"zval\":\"cat\"}"

data Reserved = Reserved
  { type_ :: String
  , xyzmodule :: Int
  , control :: Char
  }
  deriving stock (Generic, Show, Eq)
  deriving (FromJSON, ToJSON) via
    Reserved &
      GenericEncoded
        '[FieldLabelModifier := [DropPrefix "xyz", DropSuffix "_"]]

prop_drop_prefix_suffix_fields_encode_as_expected :: Property
prop_drop_prefix_suffix_fields_encode_as_expected = once . property $ do
  encode (Reserved "Sen" 9 'x') ===
    "{\"control\":\"x\",\"module\":9,\"type\":\"Sen\"}"

prop_drop_prefix_suffix_fields_decode_as_expected :: Property
prop_drop_prefix_suffix_fields_decode_as_expected = once . property $ do
  tripping (Reserved "Sen" 9 'x') encode decode
  Just (Reserved "Sen" 9 'x') ===
    decode "{\"control\":\"x\",\"module\":9,\"type\":\"Sen\"}"

newtype DashSeparatedWords = DashSeparatedWords Text
  deriving stock (Generic, Show, Eq)
  deriving (FromJSON, ToJSON) via TextWithPattern "^([A-Za-z]+-)*[A-Za-z]+$"

prop_accepts_matches :: Property
prop_accepts_matches = once . property $ do
  tripping (DashSeparatedWords "foo-bar-baz") encode decode
  Just (DashSeparatedWords "foo-bar-baz") === decode "\"foo-bar-baz\""

prop_rejects_non_matches :: Property
prop_rejects_non_matches = once . property $ do
  Left "Error in $: must match regex ^([A-Za-z]+-)*[A-Za-z]+$" === eitherDecode @DashSeparatedWords "\"foo.42\""


data Heavy = BlackHole | NeutronStar
 deriving stock (Generic, Show, Eq, Ord, Bounded, Enum)
 deriving (FromJSON, ToJSON) via GenericEncoded '[ConstructorTagModifier := FirstChar Lowercase] Heavy

prop_first_char_modifier_encodes_as_expected :: Property
prop_first_char_modifier_encodes_as_expected = once . property $ do
  encode BlackHole === "\"blackHole\""
  encode NeutronStar === "\"neutronStar\""

prop_first_char_modifier_decodes_as_expected :: Property
prop_first_char_modifier_decodes_as_expected = once . property $ do
  for_ [BlackHole ..] $ \x ->
    tripping x encode decode