{-# LANGUAGE
  BlockArguments,
  CPP,
  KindSignatures,
  RankNTypes,
  ScopedTypeVariables,
  TemplateHaskell,
  TypeApplications,
  TypeFamilies #-}

import Test.Tasty
import Test.Tasty.HUnit

import FCI
import FCI.Base
import FCI.TH
import FCI.Unsafe ((==>))

#if __GLASGOW_HASKELL__ >= 900
newtype T2 f a = T2 (f a) deriving (Eq, Show)

-- This is broken on GHC 8. Somehow the type variable is not bound correctly.
instanceDict [| viaFunctor @f :: forall f. Functor f => Dict (Functor (T2 f)) |]
#endif

defaultEq :: (a -> a -> Bool) -> DictEq a
defaultEq (.==) = Eq
  { (|==) = (.==)
  , (|/=) = \x y -> not (x .== y)
  }

defaultMonoid :: a -> (a -> a -> a) -> DictMonoid a
defaultMonoid dmempty (.<>) = Monoid
  { _Semigroup = Semigroup (.<>) undefined undefined
  , _mempty = dmempty
  , _mappend = (.<>)
  , _mconcat = undefined
  }

newtype MyInt = MyInt { unMyInt :: Int }

eqMyInt :: DictEq MyInt
eqMyInt = defaultEq (\_ _ -> True)

monoidMyInt :: DictMonoid MyInt
monoidMyInt = defaultMonoid (MyInt 0) (\(MyInt x) (MyInt y) -> MyInt (x + y))

-- Test name mangling configuration

class V a where

class V a => W a where
  w :: a

setDictOptions dictOptions
  { methodName = \_ m -> "m" ++ m
  , superclassName = \_ s _ -> "s" ++ s
  , typeName = \t -> "T" ++ t
  , constructorName = \c -> "C" ++ c
  }

mkDict ''V
mkDict ''W

setDictOptions dictOptions

cv :: TV Int
cv = CV

instanceDict [| cv :: Dict (V Int) |]

cw :: TW Int
cw = CW
  { sV = dict
  , mw = 0
  }

instanceDict [| cw :: Dict (W Int) |]

test :: TestTree
test = testGroup "FCI"
  [ testCase "dict" $
      _fmap (dict @(Functor Maybe)) (+1) (Just (1 :: Int)) @?= Just 2

  , testCase "==>" $
      eqMyInt ==>
        (MyInt 0 == MyInt 1) @?= True

  , testCase "superclass" $
      monoidMyInt ==>
        unMyInt (MyInt 1 <> MyInt 10) @?= 11

#if __GLASGOW_HASKELL__ >= 900
  , testCase "dictIntsance" $
      fmap (+1) (T2 (Just (1 :: Int))) @?= T2 (Just 2)
#endif

  , testCase "mangledNames" $
      (w :: Int) @?= 0
  ]

main :: IO ()
main = defaultMain test