-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Derive.TopDown.IsInstance
-- Copyright   :  (c) Song Zhang
-- License     :  BSD-style (see the LICENSE file)
-- 
-- Maintainer  :  haskell.zhang.song `at` hotmail.com
-- Stability   :  experimental
-- Portability :  non-portable
--
-----------------------------------------------------------------------------

module Data.Derive.TopDown.IsInstance
  ( isInstance'
  ) where

import           Data.Derive.TopDown.Types
import           Data.Generics
import           GHC.Exts
{-
Note:
  Since GHC template-haskell isInstance function cannot work with 
  polymorphic type. It cannot check whether @Eq a => [a]@ is an 
  instance of 'Eq', here 
  
  >poly_a :: Q Bool
  >poly_a = do
  >    poly_a_t <- [t| forall a. Eq a => [a] |]
  >    isInstance ''Eq [poly_a_t]
  > $(poly_a >>= stringE.show)
  >"False"
  >poly_a' :: Q Bool
  >poly_a' = do
  >    poly_a_t <- [t| forall a. [a] |]
  >    isInstance ''Eq [poly_a_t]
  > $(poly_a >>= stringE.show)
  >"False"
  
  So, here I change all the polymorphic types in the type into 'Any'

  @type family Any :: k where {}@

  See https://gitlab.haskell.org/ghc/ghc/-/issues/10607
-}
import           Language.Haskell.TH

replace_poly_type :: Type -> Type
replace_poly_type :: Type -> Type
replace_poly_type (VarT Name
_) = Name -> Type
ConT ''Any
replace_poly_type Type
x        = Type
x

replace_poly_type_trans :: Data a => a -> a
replace_poly_type_trans :: forall a. Data a => a -> a
replace_poly_type_trans = (forall a. Data a => a -> a) -> forall a. Data a => a -> a
everywhere ((Type -> Type) -> a -> a
forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
mkT Type -> Type
replace_poly_type)

remove_explicit_forall :: Type -> Type
remove_explicit_forall :: Type -> Type
remove_explicit_forall (ForallT [TyVarBndr Specificity]
_ Cxt
_ Type
t) = Type
t
remove_explicit_forall Type
t               = Type
t

remove_explicit_forall_trans :: Type -> Type
remove_explicit_forall_trans :: Type -> Type
remove_explicit_forall_trans = (forall a. Data a => a -> a) -> forall a. Data a => a -> a
everywhere ((Type -> Type) -> a -> a
forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
mkT Type -> Type
remove_explicit_forall)

isInstance' :: ClassName -> [Type] -> Q Bool
isInstance' :: Name -> Cxt -> Q Bool
isInstance' Name
cls Cxt
tys =
    let trans :: Type -> Type
trans = Type -> Type
remove_explicit_forall_trans (Type -> Type) -> (Type -> Type) -> Type -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type
forall a. Data a => a -> a
replace_poly_type_trans
      in  Name -> Cxt -> Q Bool
isInstance Name
cls ((Type -> Type) -> Cxt -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map Type -> Type
trans Cxt
tys)