SumTest.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

module Data.Aeson.Dependent.SumTest where

import Data.Aeson
  ( FromJSON (..),
    FromJSONKey (..),
    ToJSON (..),
    ToJSONKey (..),
    eitherDecode',
    encode,
    object,
    withObject,
    withText,
    (.:),
    (.=),
  )
import Data.Aeson.Dependent.Sum
import Data.ByteString.Lazy (ByteString)
import Data.Constraint.Extras (ArgDict)
import Data.Constraint.Extras.TH (deriveArgDict)
import Data.Dependent.Sum (DSum, (==>))
import Data.Functor.Identity (Identity)
import Data.GADT.Compare.TH (deriveGEq)
import Data.GADT.Show.TH (deriveGShow)
import Data.Some (Some (..), foldSome, mapSome, withSome)
import GHC.Generics (Generic)
import Hedgehog (Gen, Property, forAll, property, tripping)
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
import Test.Tasty (TestName, TestTree, testGroup)
import Test.Tasty.HUnit (testCase, (@?=))

data CharacterClass a where
  Fighter :: CharacterClass Fighter
  Rogue :: CharacterClass Rogue
  Wizard :: CharacterClass Wizard

instance FromJSON (Some CharacterClass) where
  parseJSON = withText "CharacterClass" $ \t -> case t of
    "fighter" -> pure $ Some Fighter
    "rogue" -> pure $ Some Rogue
    "wizard" -> pure $ Some Wizard
    _ -> fail $ "Unexpected CharacterClass: " <> show t

instance ToJSON (Some CharacterClass) where
  toJSON = foldSome $ \case
    Fighter -> "fighter"
    Rogue -> "rogue"
    Wizard -> "wizard"

deriving anyclass instance FromJSONKey (Some CharacterClass)

deriving anyclass instance ToJSONKey (Some CharacterClass)

data Fighter = F
  { favouredWeapon :: String,
    attackBonus :: Int
  }
  deriving stock (Eq, Show, Generic)
  deriving anyclass (FromJSON, ToJSON)

data Rogue = R
  { sneakiness :: Int,
    skills :: [String]
  }
  deriving stock (Eq, Show, Generic)
  deriving anyclass (FromJSON, ToJSON)

data Wizard = W
  { frogsLegs :: Int,
    eyesOfNewt :: Int,
    darkPatron :: String
  }
  deriving stock (Eq, Show, Generic)
  deriving anyclass (FromJSON, ToJSON)

-- This has to be after the individual class records, as GHC cannot
-- look beyond the splices.
$(deriveArgDict ''CharacterClass)
$(deriveGEq ''CharacterClass)
$(deriveGShow ''CharacterClass)

-- Newtype with contrived FromJSONKey/ToJSONKey instances to test
-- non-string encoding/decoding.
newtype NonStringKeyCharacterClass a
  = NonStringKeyCharacterClass (CharacterClass a)
  deriving newtype (ArgDict c)

instance FromJSON (Some NonStringKeyCharacterClass) where
  parseJSON =
    withObject "NonStringKeyCharacterClass" $ \o ->
      mapSome NonStringKeyCharacterClass <$> o .: "class"

instance ToJSON (Some NonStringKeyCharacterClass) where
  toJSON (Some (NonStringKeyCharacterClass c)) =
    object ["class" .= Some c]

instance FromJSONKey (Some NonStringKeyCharacterClass)

instance ToJSONKey (Some NonStringKeyCharacterClass)

newtype CharacterTaggedObjectInline = CharacterTaggedObjectInline (DSum CharacterClass Identity)
  deriving stock (Eq, Show)
  deriving
    (FromJSON, ToJSON)
    via (TaggedObjectInline "Character" "class" CharacterClass Identity)

newtype CharacterTaggedObject = CharacterTaggedObject (DSum CharacterClass Identity)
  deriving stock (Eq, Show)
  deriving
    (FromJSON, ToJSON)
    via (TaggedObject "Character" "class" "data" CharacterClass Identity)

newtype CharacterObjectWithSingleField = CharacterObjectWithSingleField (DSum CharacterClass Identity)
  deriving stock (Eq, Show)
  deriving
    (FromJSON, ToJSON)
    via (ObjectWithSingleField "Character" CharacterClass Identity)

newtype CharacterObjectWithSingleDodgyField = CharacterObjectWithSingleDodgyField (DSum CharacterClass Identity)
  deriving stock (Eq, Show)
  deriving
    (FromJSON, ToJSON)
    via (ObjectWithSingleField "Character" NonStringKeyCharacterClass Identity)

newtype CharacterTwoElemArray = CharacterTwoElemArray (DSum CharacterClass Identity)
  deriving stock (Eq, Show)
  deriving
    (FromJSON, ToJSON)
    via (TwoElemArray "Character" CharacterClass Identity)

-- Unit Tests --

test_DecodeTaggedObjectInline :: TestTree
test_DecodeTaggedObjectInline =
  makeParseTests
    "DecodeTaggedObjectInline"
    taggedObjectInlineJson
    CharacterTaggedObjectInline

test_DecodeTaggedObject :: TestTree
test_DecodeTaggedObject =
  makeParseTests
    "DecodeTaggedObject"
    taggedObjectJson
    CharacterTaggedObject

test_DecodeObjectWithSingleField :: TestTree
test_DecodeObjectWithSingleField =
  makeParseTests
    "ObjectWithSingleField"
    objectWithSingleFieldJson
    CharacterObjectWithSingleField

test_DecodeObjectWithSingleDodgyField :: TestTree
test_DecodeObjectWithSingleDodgyField =
  makeParseTests
    "ObjectWithSingleDodgyField"
    objectWithSingleDodgyFieldJson
    CharacterObjectWithSingleDodgyField

test_DecodeTwoElemArray :: TestTree
test_DecodeTwoElemArray =
  makeParseTests
    "TwoElemArray"
    twoElemArrayJson
    CharacterTwoElemArray

makeParseTests ::
  (Eq a, FromJSON a, Show a) =>
  TestName ->
  (forall x. CharacterClass x -> ByteString) ->
  (DSum CharacterClass Identity -> a) ->
  TestTree
makeParseTests label jsonFor wrap =
  testGroup
    label
    [ testCase "fighter" $
        eitherDecode' (jsonFor Fighter)
          @?= Right (wrap $ expectedParses Fighter),
      testCase "rogue" $
        eitherDecode' (jsonFor Rogue)
          @?= Right (wrap $ expectedParses Rogue),
      testCase "wizard" $
        eitherDecode' (jsonFor Wizard)
          @?= Right (wrap $ expectedParses Wizard)
    ]

expectedParses :: CharacterClass a -> DSum CharacterClass Identity
expectedParses = \case
  Fighter ->
    Fighter
      ==> F
        { favouredWeapon = "greatsword",
          attackBonus = 12
        }
  Rogue ->
    Rogue
      ==> R
        { sneakiness = 999,
          skills = ["sneaking", "stealing", "lockpicking"]
        }
  Wizard ->
    Wizard
      ==> W
        { frogsLegs = 42,
          eyesOfNewt = 9001,
          darkPatron = "Damo"
        }

taggedObjectInlineJson :: CharacterClass a -> ByteString
taggedObjectInlineJson = \case
  Fighter ->
    "{\
    \  \"class\": \"fighter\",\
    \  \"favouredWeapon\": \"greatsword\",\
    \  \"attackBonus\": 12\
    \}"
  Rogue ->
    "{\
    \  \"class\": \"rogue\",\
    \  \"sneakiness\": 999,\
    \  \"skills\": [\"sneaking\", \"stealing\", \"lockpicking\"]\
    \}"
  Wizard ->
    "{\
    \  \"class\": \"wizard\",\
    \  \"frogsLegs\": 42,\
    \  \"eyesOfNewt\": 9001,\
    \  \"darkPatron\": \"Damo\"\
    \}"

taggedObjectJson :: CharacterClass a -> ByteString
taggedObjectJson = \case
  Fighter ->
    "{\
    \  \"class\": \"fighter\",\
    \  \"data\": {\
    \    \"favouredWeapon\": \"greatsword\",\
    \    \"attackBonus\": 12\
    \  }\
    \}"
  Rogue ->
    "{\
    \  \"class\": \"rogue\",\
    \  \"data\": {\
    \    \"sneakiness\": 999,\
    \    \"skills\": [\"sneaking\", \"stealing\", \"lockpicking\"]\
    \  }\
    \}"
  Wizard ->
    "{\
    \  \"class\": \"wizard\",\
    \  \"data\": {\
    \    \"frogsLegs\": 42,\
    \    \"eyesOfNewt\": 9001,\
    \    \"darkPatron\": \"Damo\"\
    \  }\
    \}"

objectWithSingleFieldJson :: CharacterClass a -> ByteString
objectWithSingleFieldJson = \case
  Fighter ->
    "{\
    \  \"fighter\": {\
    \    \"favouredWeapon\": \"greatsword\",\
    \    \"attackBonus\": 12\
    \  }\
    \}"
  Rogue ->
    "{\
    \  \"rogue\": {\
    \    \"sneakiness\": 999,\
    \    \"skills\": [\"sneaking\", \"stealing\", \"lockpicking\"]\
    \  }\
    \}"
  Wizard ->
    "{\
    \  \"wizard\": {\
    \    \"frogsLegs\": 42,\
    \    \"eyesOfNewt\": 9001,\
    \    \"darkPatron\": \"Damo\"\
    \  }\
    \}"

objectWithSingleDodgyFieldJson :: CharacterClass a -> ByteString
objectWithSingleDodgyFieldJson = \case
  Fighter ->
    "[\
    \  { \"class\": \"fighter\" },\
    \  {\
    \    \"favouredWeapon\": \"greatsword\",\
    \    \"attackBonus\": 12\
    \  }\
    \]"
  Rogue ->
    "[\
    \  { \"class\": \"rogue\" },\
    \  {\
    \    \"sneakiness\": 999,\
    \    \"skills\": [\"sneaking\", \"stealing\", \"lockpicking\"]\
    \  }\
    \]"
  Wizard ->
    "[\
    \  { \"class\": \"wizard\" },\
    \  {\
    \    \"frogsLegs\": 42,\
    \    \"eyesOfNewt\": 9001,\
    \    \"darkPatron\": \"Damo\"\
    \  }\
    \]"

twoElemArrayJson :: CharacterClass a -> ByteString
twoElemArrayJson = \case
  Fighter ->
    "[\
    \  \"fighter\",\
    \  {\
    \    \"favouredWeapon\": \"greatsword\",\
    \    \"attackBonus\": 12\
    \  }\
    \]"
  Rogue ->
    "[\
    \  \"rogue\",\
    \  {\
    \    \"sneakiness\": 999,\
    \    \"skills\": [\"sneaking\", \"stealing\", \"lockpicking\"]\
    \  }\
    \]"
  Wizard ->
    "[\
    \  \"wizard\",\
    \  {\
    \    \"frogsLegs\": 42,\
    \    \"eyesOfNewt\": 9001,\
    \    \"darkPatron\": \"Damo\"\
    \  }\
    \]"

-- Property Tests --

genCharacterDSum :: Gen (DSum CharacterClass Identity)
genCharacterDSum = do
  let string :: Gen String
      string = Gen.string (Range.linear 1 100) Gen.unicode
      int :: Gen Int
      int = Gen.int (Range.linear 1 100)
      list :: Gen a -> Gen [a]
      list = Gen.list (Range.linear 1 100)

  someClass <- Gen.element [Some Fighter, Some Rogue, Some Wizard]
  withSome someClass $ \case
    Fighter ->
      (Fighter ==>) <$> do
        favouredWeapon <- string
        attackBonus <- int
        pure F {..}
    Rogue ->
      (Rogue ==>) <$> do
        sneakiness <- int
        skills <- list string
        pure R {..}
    Wizard ->
      (Wizard ==>) <$> do
        frogsLegs <- int
        eyesOfNewt <- int
        darkPatron <- string
        pure W {..}

hprop_TrippingTaggedObjectInline :: Property
hprop_TrippingTaggedObjectInline = property $ do
  ch <- forAll genCharacterDSum
  tripping (CharacterTaggedObjectInline ch) encode eitherDecode'

hprop_TrippingTaggedObject :: Property
hprop_TrippingTaggedObject = property $ do
  ch <- forAll genCharacterDSum
  tripping (CharacterTaggedObject ch) encode eitherDecode'

hprop_TrippingObjectWithSingleField :: Property
hprop_TrippingObjectWithSingleField = property $ do
  ch <- forAll genCharacterDSum
  tripping (CharacterObjectWithSingleField ch) encode eitherDecode'

hprop_TrippingObjectWithSingleDodgyField :: Property
hprop_TrippingObjectWithSingleDodgyField = property $ do
  ch <- forAll genCharacterDSum
  tripping (CharacterObjectWithSingleDodgyField ch) encode eitherDecode'

hprop_TrippingTwoElemArray :: Property
hprop_TrippingTwoElemArray = property $ do
  ch <- forAll genCharacterDSum
  tripping (CharacterTwoElemArray ch) encode eitherDecode'