{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
module Main where

import Data.Aeson (FromJSON(parseJSON), Result(Success), ToJSON(toJSON), Value, fromJSON)
import Data.Aeson.QQ.Simple (aesonQQ)
import Data.Override (Override(Override), As, At, With)
import Data.Override.Aeson (AesonOption(..), WithAesonOptions(..))
import Data.Text (Text)
import GHC.Generics (Generic)
import LispCaseAeson (LispCase(LispCase))
import Test.Hspec
import Text.Read (readMaybe)

import qualified Data.Text as Text

main :: IO ()
main = hspec do
  describe "Override ToJSON machinery" do
    it "Rec1" testRec1
    it "Rec2" testRec2
    it "Rec3" testRec3
    it "Rec4" testRec4
    it "Rec5" testRec5
    it "Rec6" testRec6
    it "Rec7" testRec6
    it "Sum1" testSum1
    it "Options1" testOptions1

newtype Uptext = Uptext { unUptext :: Text }

instance ToJSON Uptext where
  toJSON = toJSON . Text.toUpper . unUptext

newtype Shown a = Shown { unShown :: a }

instance (Show a) => ToJSON (Shown a) where
  toJSON = toJSON . show . unShown
instance (Read a) => FromJSON (Shown a) where
  parseJSON v = do
    s <- parseJSON v
    case readMaybe s of
      Nothing -> fail "read: no parse"
      Just a -> pure $ Shown a

newtype CharArray s = CharArray { unCharArray :: s }
  deriving stock (Functor)

instance ToJSON (CharArray String) where
  toJSON = toJSON . map (:[]) . unCharArray

instance FromJSON (CharArray String) where
  parseJSON v = do
    cs :: [String] <- parseJSON v
    pure $ CharArray $ concat cs

instance ToJSON (CharArray Text) where
  toJSON = toJSON . fmap Text.unpack

-- | Overriding instances by type.
data Rec1 = Rec1
  { foo :: Int
  , bar :: String
  , baz :: Text
  } deriving stock (Show, Eq, Generic)
    deriving (ToJSON)
      via Override Rec1
            '[ Text `As` Uptext
             , Int `As` Shown Int
             ]

testRec1 :: IO ()
testRec1 = do
  toJSON Rec1 { foo = 12, bar = "hi", baz = "bye" }
    `shouldBe` [aesonQQ|
    {
      "foo": "12",
      "bar": "hi",
      "baz": "BYE"
    }
  |]

-- | Overriding instances by field name.
data Rec2 = Rec2
  { foo :: Int
  , bar :: Text
  , baz :: Text
  } deriving stock (Show, Eq, Generic)
    deriving (ToJSON)
      via Override Rec2
            '[ "baz" `As` CharArray Text
             , "bar" `As` Uptext
             ]

testRec2 :: IO ()
testRec2 = do
  toJSON Rec2 { foo = 12, bar = "hi", baz = "bye" }
    `shouldBe` [aesonQQ|
    {
      "foo": 12,
      "bar": "HI",
      "baz": ["b", "y", "e"]
    }
  |]

-- | Overriding instances by type and field name.
data Rec3 = Rec3
  { foo :: Int
  , bar :: String
  , baz :: Text
  } deriving stock (Show, Eq, Generic)
    deriving (ToJSON)
      via Override Rec3
            '[ String `As` CharArray String
             , "foo" `As` Shown Int
             , Text `As` Uptext
             ]

testRec3 :: IO ()
testRec3 = do
  toJSON Rec3 { foo = 12, bar = "hi", baz = "bye" }
    `shouldBe` [aesonQQ|
    {
      "foo": "12",
      "bar": ["h", "i"],
      "baz": "BYE"
    }
  |]

-- | Overriding instance by type and field name; first match wins.
-- In this case, 'foo' and 'bar' use 'CharArray Text' and 'baz' uses 'Uptext'.
data Rec4 = Rec4
  { foo :: Text
  , bar :: Text
  , baz :: Text
  } deriving stock (Show, Eq, Generic)
    deriving (ToJSON)
      via Override Rec4
            '[ "baz" `As` Uptext
             , Text `As` CharArray Text
             ]

testRec4 :: IO ()
testRec4 = do
  toJSON Rec4 { foo = "go", bar = "hi", baz = "bye" }
    `shouldBe` [aesonQQ|
    {
      "foo": ["g", "o"],
      "bar": ["h", "i"],
      "baz": "BYE"
    }
  |]

-- We can compose an 'Override' with another deriving-via newtype, 'LispCase'.
data Rec5 = Rec5
  { fooBar :: Int
  , baz :: Text
  , quuxSpamEggs :: String
  } deriving stock (Show, Eq, Generic)
    deriving (ToJSON)
      via LispCase (Override Rec5
            '[ "fooBar" `As` Shown Int
             , Text `As` Uptext
             , "quuxSpamEggs" `As` CharArray String
             ])

testRec5 :: IO ()
testRec5 = do
  toJSON Rec5 { fooBar = 1, baz = "hi", quuxSpamEggs = "bye" }
    `shouldBe` [aesonQQ|
      {
        "foo-bar": "1",
        "baz": "HI",
        "quux-spam-eggs": ["b", "y", "e"]
      }
    |]

-- Test 'Override' for both 'ToJSON' and 'FromJSON'.
data Rec6 = Rec6
  { foo :: Int
  , bar :: String
  , baz :: Text
  } deriving stock (Show, Eq, Generic)
    deriving (ToJSON, FromJSON)
      via Override Rec6
            '[ "foo" `As` Shown Int
             , String `As` CharArray String
             ]

testRec6 :: IO ()
testRec6 = do
  Rec6 { foo = 1, bar = "hi", baz = "bye" }
    `shouldRoundtripAs` [aesonQQ|
      {
        "foo": "1",
        "bar": ["h", "i"],
        "baz": "bye"
      }
    |]

-- Test 'Override' for both 'ToJSON' and 'FromJSON'.
data Rec7 = Rec7
  { foo :: Int
  , bar :: String
  , baz :: Text
  } deriving stock (Show, Eq, Generic)
    deriving (ToJSON, FromJSON)
      via Override Rec7
            '[ "foo" `With` Shown
             , String `With` CharArray
             ]

testRec7 :: IO ()
testRec7 = do
  Rec7 { foo = 1, bar = "hi", baz = "bye" }
    `shouldRoundtripAs` [aesonQQ|
      {
        "foo": "1",
        "bar": ["h", "i"],
        "baz": "bye"
      }
    |]

newtype Reverse a = Reverse [a]

instance (ToJSON a) => ToJSON (Reverse a) where
  toJSON (Reverse xs) = toJSON $ reverse xs

instance (FromJSON a) => FromJSON (Reverse a) where
  parseJSON = fmap (Reverse . reverse) . parseJSON

newtype Not = Not Bool

instance ToJSON Not where
  toJSON (Not b) = toJSON $ not b

instance FromJSON Not where
  parseJSON = fmap (Not . not) . parseJSON

data Sum1 a =
    Sum1List [a]
  | Sum1Trip a Char Bool
  | Sum1Null
  deriving stock (Show, Eq, Generic)
  deriving (ToJSON, FromJSON)
    via Override (Sum1 a)
          '[ At "Sum1List" 0 (Reverse a)
           , At "Sum1Trip" 2 Not
           ]

testSum1 :: IO ()
testSum1 = do
  Sum1List ['a', 'b'] `shouldRoundtripAs` [aesonQQ|
    {
      "tag": "Sum1List",
      "contents": "ba"
    }
  |]
  Sum1Trip 'a' 'b' True `shouldRoundtripAs` [aesonQQ|
    {
      "tag": "Sum1Trip",
      "contents": ["a", "b", false]
    }
  |]
  Sum1Null @Char `shouldRoundtripAs` [aesonQQ|
    {
      "tag": "Sum1Null"
    }
  |]


data Options1 =
    Options1A { foo :: Maybe Int, bar :: String }
  | Options1B Options1BBody
  | Options1C
    deriving stock (Eq, Show, Generic)
    deriving (FromJSON, ToJSON)
      via Override Options1
            '[ "foo" `As` Maybe (Shown Int)
             ] `WithAesonOptions`
            '[ 'OmitNothingFields
             , 'SumEncodingTaggedObject "type" "data"
             ]

data Options1BBody = Options1BBody { baz :: Int }
  deriving stock (Eq, Show, Generic)
  deriving anyclass (FromJSON, ToJSON)

testOptions1 :: IO ()
testOptions1 = do
  Options1A { foo = Nothing, bar = "boo" }
    `shouldRoundtripAs` [aesonQQ| { "type": "Options1A", "bar": "boo" } |]
  Options1A { foo = Just 1, bar = "boo" }
    `shouldRoundtripAs` [aesonQQ| { "type": "Options1A", "foo": "1", "bar": "boo" } |]
  Options1B Options1BBody { baz = 2 }
    `shouldRoundtripAs` [aesonQQ| { "type": "Options1B", "data": { "baz": 2 } } |]
  Options1C
    `shouldRoundtripAs` [aesonQQ| { "type": "Options1C" } |]

shouldRoundtripAs
  :: (ToJSON a, FromJSON a, Eq a, Show a, HasCallStack)
  => a -> Value -> IO ()
shouldRoundtripAs x j = do
  toJSON x `shouldBe` j
  fromJSON j `shouldBe` Success x