{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}

module Test.Some
  ( someTests
  )
where

import           Data.Type.Equality (TestEquality(testEquality), (:~:)(Refl))
import           Control.Lens (Lens', lens, view, set)

import           Test.Tasty (TestTree, testGroup)
import           Test.Tasty.HUnit (assertEqual, testCase)

import           Data.Parameterized.Classes (ShowF)
import           Data.Parameterized.Some (Some(Some), someLens)

data Item b where
  BoolItem :: Item Bool
  IntItem :: Item Int

instance Show (Item b) where
  show =
    \case
      BoolItem -> "BoolItem"
      IntItem -> "IntItem"

instance TestEquality Item where
  testEquality x y =
    case (x, y) of
      (BoolItem, BoolItem) -> Just Refl
      (IntItem, IntItem) -> Just Refl
      _ -> Nothing

data Pair a b =
  Pair
    { _fir :: a
    , _sec :: Item b
    }

-- This instance isn't compatible with the intended use of TestEquality (which
-- is supposed to be just for singletons), but it seems fine for tests.
instance Eq a => TestEquality (Pair a) where
  testEquality x y =
    case testEquality (_sec x) (_sec y) of
      Just Refl -> if _fir x == _fir y then Just Refl else Nothing
      Nothing -> Nothing

instance (Show a) => Show (Pair a b) where
  show (Pair a b) = "Pair(" ++ show a ++ ", " ++ show b ++ ")"

instance Show a => ShowF (Pair a)

fir :: Lens' (Pair a b) a
fir = lens _fir (\s v -> s { _fir = v })

someFir :: Lens' (Some (Pair a)) a
someFir = someLens fir

someTests :: IO TestTree
someTests =
  testGroup "Some" <$>
    return
      [ testCase "someLens: view . set" $
          assertEqual
            "view l . set l x == const x"
            (view someFir (set someFir 5 (Some (Pair 1 BoolItem))))
            (5 :: Int)
      , testCase "someLens: set . set" $
          assertEqual
            "set l y . set l x == set l y"
            (set someFir 4 (set someFir 5 (Some (Pair 1 IntItem))))
            (Some (Pair (4 :: Int) IntItem))
      ]