SumType.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}

module Tests.SumType where

import Data.Aeson (ToJSON, eitherDecode, encode)
import Data.Proxy (Proxy (..))
import Data.String (fromString)
import Test.Tasty
import Test.Tasty.Golden
import Test.Tasty.HUnit
import Test.Tasty.QuickCheck

import Data.Aeson.Schema.Utils.Sum (SumType (..), fromSumType)

type SpecialJSON = SumType '[Bool, Int, [String]]

toSpecialJSON :: ToJSON a => a -> SpecialJSON
toSpecialJSON = either (error . ("Invalid SpecialJSON: " ++) . show) id . toSpecialJSON'

toSpecialJSON' :: ToJSON a => a -> Either String SpecialJSON
toSpecialJSON' = eitherDecode . encode

{- Tests -}

test :: TestTree
test =
  testGroup
    "SumType"
    [ testCase "Sanity checks" $
        -- this should compile
        let values =
              [ Here True
              , Here False
              , There (Here 1)
              , There (Here 10)
              , There (There (Here []))
              , There (There (Here ["a"]))
              ] ::
                [SpecialJSON]
         in values @?= values
    , testDecode
    , testFromSumType
    ]

testDecode :: TestTree
testDecode =
  testGroup
    "Decode SumType"
    [ testProperty "branch 1" $ \(b :: Bool) ->
        toSpecialJSON' b === Right (Here b)
    , testProperty "branch 2" $ \(x :: Int) ->
        toSpecialJSON' x === Right (There (Here x))
    , testProperty "branch 3" $ \(l :: [String]) ->
        toSpecialJSON' l === Right (There (There (Here l)))
    , goldenVsString "invalid SumType" "test/goldens/sumtype_decode_invalid.golden" $
        case toSpecialJSON' [True] of
          Right v -> error $ "Unexpectedly decoded value: " ++ show v
          Left e -> pure $ fromString e
    ]

testFromSumType :: TestTree
testFromSumType =
  testGroup
    "fromSumType"
    [ testProperty "branch 0 valid" $ \b ->
        fromSumType (Proxy @0) (toSpecialJSON b) === Just b
    , testProperty "branch 0 invalid" $
        forAll (specialJSONExcept 0) $ \(branch, value) ->
          labelBranch branch $ fromSumType (Proxy @0) value === Nothing
    , testProperty "branch 1 valid" $ \x ->
        fromSumType (Proxy @1) (toSpecialJSON x) === Just x
    , testProperty "branch 1 invalid" $
        forAll (specialJSONExcept 1) $ \(branch, value) ->
          labelBranch branch $ fromSumType (Proxy @1) value === Nothing
    , testProperty "branch 2 valid" $ \l ->
        fromSumType (Proxy @2) (toSpecialJSON l) === Just l
    , testProperty "branch 2 invalid" $
        forAll (specialJSONExcept 2) $ \(branch, value) ->
          labelBranch branch $ fromSumType (Proxy @2) value === Nothing
    ]
  where
    specialJSONExcept :: Int -> Gen (Int, SpecialJSON)
    specialJSONExcept validBranch =
      let fmapFst (a, gen) = (a,) <$> gen
       in oneof $
            map fmapFst $
              filter
                ((/= validBranch) . fst)
                [ (0, toSpecialJSON <$> arbitrary @Bool)
                , (1, toSpecialJSON <$> arbitrary @Int)
                , (2, toSpecialJSON <$> arbitrary @[String])
                ]

    labelBranch branch = label $ "branch " ++ show branch