-----------------------------------------------------------------------------
-- |
-- 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.Lib
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 ClassName
_) = ClassName -> 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' :: ClassName -> Cxt -> Q Bool
isInstance' ClassName
cls Cxt
tys = if ClassName
cls ClassName -> ClassName -> Bool
forall a. Eq a => a -> a -> Bool
== ''Typeable
                        -- After GHC 7.10, GHC will generate Typeable 
                        -- instance for all types, so this could be fine.
  then Bool -> Q Bool
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
  else
    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  ClassName -> Cxt -> Q Bool
isInstance ClassName
cls ((Type -> Type) -> Cxt -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map Type -> Type
trans Cxt
tys)