{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE RankNTypes#-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GADTs #-}
{-# OPTIONS_GHC -Wno-unused-imports #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Derive.TopDown.Lib
-- 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.Lib where 

import Language.Haskell.TH
import Language.Haskell.TH.Syntax hiding (lift)
import Data.Generics
import GHC.Exts
import Language.Haskell.TH.ExpandSyns (expandSynsWith,noWarnTypeFamilies,expandSyns)
import Data.List (nub)
import Control.Monad.State
import Control.Monad.Trans
import Control.Applicative
import Control.Monad
import Data.Derive.TopDown.Types
import Language.Haskell.TH.Datatype (
    ConstructorInfo(..),
    DatatypeInfo(..),
    reifyDatatype
    )

noWarnExpandSynsWith :: Type -> Q Type
noWarnExpandSynsWith :: Kind -> Q Kind
noWarnExpandSynsWith = SynonymExpansionSettings -> Kind -> Q Kind
expandSynsWith SynonymExpansionSettings
noWarnTypeFamilies

{-|
  Get the type variable name.
-}
getVarName :: Type -> [Name]
getVarName :: Kind -> [Name]
getVarName (VarT Name
n) = [Name
n]
getVarName Kind
_ = []

{-|
  Get the type variable names.
-}
getAllVarNames :: Data a => a -> [Name]
getAllVarNames :: forall a. Data a => a -> [Name]
getAllVarNames = ([Name] -> [Name] -> [Name])
-> (forall a. Data a => a -> [Name])
-> forall a. Data a => a -> [Name]
forall r. (r -> r -> r) -> GenericQ r -> GenericQ r
everything [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
(++) ([Name] -> (Kind -> [Name]) -> a -> [Name]
forall a b r. (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
mkQ [] Kind -> [Name]
getVarName)

substitute :: (Type, Type) -> Type -> Type
substitute :: (Kind, Kind) -> Kind -> Kind
substitute (VarT Name
m, Kind
t) x :: Kind
x@(VarT Name
n) = if Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
m 
                                    then Kind
t
                                    else Kind
x
substitute (VarT Name
_, Kind
_) Kind
x = Kind
x
substitute (Kind
t, Kind
_) Kind
x = [Char] -> Kind
forall a. HasCallStack => [Char] -> a
error ([Char] -> Kind) -> [Char] -> Kind
forall a b. (a -> b) -> a -> b
$ [Char]
"cannot substitute " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Kind -> [Char]
forall a. Show a => a -> [Char]
show Kind
t [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" with " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Kind -> [Char]
forall a. Show a => a -> [Char]
show Kind
x

substituteVar :: (Type, Type) -> Type -> Type
substituteVar :: (Kind, Kind) -> Kind -> Kind
substituteVar (Kind, Kind)
s = (forall a. Data a => a -> a) -> forall a. Data a => a -> a
everywhere ((Kind -> Kind) -> a -> a
forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
mkT ((Kind, Kind) -> Kind -> Kind
substitute (Kind, Kind)
s))

substituteVars :: [(Type, Type)] -> Type -> Type
substituteVars :: [(Kind, Kind)] -> Kind -> Kind
substituteVars [(Kind, Kind)]
ss Kind
y = ((Kind, Kind) -> Kind -> Kind) -> Kind -> [(Kind, Kind)] -> Kind
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Kind, Kind) -> Kind -> Kind
substituteVar Kind
y [(Kind, Kind)]
ss

substituteVarsTypes :: [(Type, Type)] -> [Type] -> [Type]
substituteVarsTypes :: [(Kind, Kind)] -> [Kind] -> [Kind]
substituteVarsTypes [(Kind, Kind)]
ms [Kind]
ts = [[(Kind, Kind)] -> Kind -> Kind
substituteVars [(Kind, Kind)]
ms Kind
y| Kind
y <- [Kind]
ts]

{-|
  Is the type a type family
-}
isTypeFamily :: TypeName -> Q Bool
isTypeFamily :: Name -> Q Bool
isTypeFamily Name
tn = do
                Info
info <- Name -> Q Info
reify Name
tn
                case Info
info of
                  FamilyI (OpenTypeFamilyD TypeFamilyHead
_) [Dec]
_     -> Bool -> Q Bool
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                  FamilyI (ClosedTypeFamilyD TypeFamilyHead
_ [TySynEqn]
_) [Dec]
_ -> Bool -> Q Bool
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True 
                  Info
_                                 -> Bool -> Q Bool
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

isDataNewtype :: TypeName -> Q Bool
isDataNewtype :: Name -> Q Bool
isDataNewtype Name
tn = do
                Info
info <- Name -> Q Info
reify Name
tn
                case Info
info of
                  TyConI (DataD [Kind]
_ Name
_ [TyVarBndr BndrVis]
_ Maybe Kind
_ [Con]
_ [DerivClause]
_)    -> Bool -> Q Bool
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                  TyConI (NewtypeD [Kind]
_ Name
_ [TyVarBndr BndrVis]
_ Maybe Kind
_ Con
_ [DerivClause]
_) -> Bool -> Q Bool
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True 
                  Info
_                             -> Bool -> Q Bool
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

{-
  For type appications like @(k a b)@, @Either Int a@, we always need to 
  get the left most type in such cases
-}
getLeftMostType :: Type -> Type
getLeftMostType :: Kind -> Kind
getLeftMostType (AppT Kind
t1 Kind
_) = Kind -> Kind
getLeftMostType Kind
t1
getLeftMostType (ParensT Kind
t)  = Kind -> Kind
getLeftMostType Kind
t
getLeftMostType Kind
t            = Kind
t

isLeftMostAppTTypeFamily :: Type -> Q Bool
isLeftMostAppTTypeFamily :: Kind -> Q Bool
isLeftMostAppTTypeFamily (Kind -> Kind
getLeftMostType -> ConT Name
n) = Name -> Q Bool
isTypeFamily Name
n
isLeftMostAppTTypeFamily Kind
_                           = Bool -> Q Bool
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

isLeftMostAppTTypeVar :: Type -> Q Bool
isLeftMostAppTTypeVar :: Kind -> Q Bool
isLeftMostAppTTypeVar (Kind -> Kind
getLeftMostType -> VarT Name
_) = Bool -> Q Bool
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
isLeftMostAppTTypeVar Kind
_                           = Bool -> Q Bool
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

-- not sure how to handle ArrowT with deriving yet
isLeftMostAppTArrowT :: Type -> Bool
isLeftMostAppTArrowT :: Kind -> Bool
isLeftMostAppTArrowT (Kind -> Kind
getLeftMostType -> Kind
ArrowT)  = Bool
True
#if __GLASGOW_HASKELL__ >= 900
isLeftMostAppTArrowT (Kind -> Kind
getLeftMostType -> Kind
MulArrowT)  = Bool
True
#endif
isLeftMostAppTArrowT Kind
_ = Bool
False

isLeftMostBuildInContextType :: Type -> Bool
isLeftMostBuildInContextType :: Kind -> Bool
isLeftMostBuildInContextType (Kind -> Kind
getLeftMostType -> TupleT Int
_)  = Bool
True
isLeftMostBuildInContextType (Kind -> Kind
getLeftMostType -> Kind
ListT)     = Bool
True
isLeftMostBuildInContextType Kind
_ = Bool
False


isLeftMostAppTDataNewtype :: Type -> Q Bool
isLeftMostAppTDataNewtype :: Kind -> Q Bool
isLeftMostAppTDataNewtype (Kind -> Kind
getLeftMostType -> ConT Name
n) = Name -> Q Bool
isDataNewtype Name
n
isLeftMostAppTDataNewtype Kind
_                           = Bool -> Q Bool
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

{-| 
  Get type variable name
-}
#if __GLASGOW_HASKELL__ >= 900
getTVBName :: TyVarBndr a -> Name
getTVBName :: forall a. TyVarBndr a -> Name
getTVBName (PlainTV Name
name a
_)    = Name
name
getTVBName (KindedTV Name
name a
_ Kind
_) = Name
name
#else
getTVBName :: TyVarBndr -> Name
getTVBName (PlainTV name)    = name
getTVBName (KindedTV name _) = name
#endif

{-| After unapplying left most cannot be AppT and AppKindT, but can be InfixT or others -}
unappTy :: Type -> [Type]
unappTy :: Kind -> [Kind]
unappTy (AppT Kind
t1 Kind
t2) = Kind -> [Kind]
unappTy Kind
t1 [Kind] -> [Kind] -> [Kind]
forall a. [a] -> [a] -> [a]
++ [Kind
t2]
#if __GLASGOW_HASKELL__ >= 808
unappTy (AppKindT Kind
ty Kind
_) = Kind -> [Kind]
unappTy Kind
ty
#endif
unappTy Kind
t = [Kind
t]

getConstrArgs :: Type -> [Type]
getConstrArgs :: Kind -> [Kind]
getConstrArgs = [Kind] -> [Kind]
forall a. HasCallStack => [a] -> [a]
tail ([Kind] -> [Kind]) -> (Kind -> [Kind]) -> Kind -> [Kind]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Kind -> [Kind]
unappTy

#if __GLASGOW_HASKELL__ >= 900
voidTyVarBndrFlag :: TyVarBndr flag -> TyVarBndr ()
voidTyVarBndrFlag :: forall flag. TyVarBndr flag -> TyVarBndr ()
voidTyVarBndrFlag (PlainTV Name
n flag
_) = Name -> () -> TyVarBndr ()
forall flag. Name -> flag -> TyVarBndr flag
PlainTV Name
n ()
voidTyVarBndrFlag (KindedTV Name
n flag
_ Kind
k) = Name -> () -> Kind -> TyVarBndr ()
forall flag. Name -> flag -> Kind -> TyVarBndr flag
KindedTV Name
n () Kind
k
#else
voidTyVarBndrFlag :: TyVarBndr -> TyVarBndr
voidTyVarBndrFlag = id
#endif


isHigherOrderClass :: ClassName -> Q Bool
isHigherOrderClass :: Name -> Q Bool
isHigherOrderClass Name
cn = do
    Info
cla <- Name -> Q Info
reify Name
cn
    case Info
cla of
        ClassI (ClassD [Kind]
_ Name
_ [TyVarBndr BndrVis]
vars [FunDep]
_ [Dec]
_) [Dec]
_ 
            -> case [TyVarBndr BndrVis] -> TyVarBndr BndrVis
forall a. HasCallStack => [a] -> a
head [TyVarBndr BndrVis]
vars of
#if __GLASGOW_HASKELL__ >= 900
                  KindedTV Name
_ BndrVis
_ Kind
k -> do 
#else
                  KindedTV _ k -> do 
#endif
                              if Kind
k Kind -> Kind -> Bool
forall a. Eq a => a -> a -> Bool
== Kind
StarT
                                then Bool -> Q Bool
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                                else Bool -> Q Bool
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                  TyVarBndr BndrVis
_ -> [Char] -> Q Bool
forall a. HasCallStack => [Char] -> a
error ([Char] -> Q Bool) -> [Char] -> Q Bool
forall a b. (a -> b) -> a -> b
$ [Char]
"Cannot reify kind of class " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
forall a. Show a => a -> [Char]
show Name
cn
        Info
_ -> [Char] -> Q Bool
forall a. HasCallStack => [Char] -> a
error ([Char] -> Q Bool) -> [Char] -> Q Bool
forall a b. (a -> b) -> a -> b
$ Name -> [Char]
forall a. Show a => a -> [Char]
show Name
cn [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" is not a class"

getGadtCon :: Con -> [Con]
getGadtCon :: Con -> [Con]
getGadtCon g :: Con
g@(GadtC [Name]
_ [BangType]
_ Kind
_) = [Con
g]
getGadtCon g :: Con
g@(RecGadtC [Name]
_ [VarBangType]
_ Kind
_) = [Con
g]
getGadtCon Con
_ = []

getAllGadtCons :: Data a => a -> [Con]
getAllGadtCons :: forall a. Data a => a -> [Con]
getAllGadtCons = ([Con] -> [Con] -> [Con])
-> (forall a. Data a => a -> [Con])
-> forall a. Data a => a -> [Con]
forall r. (r -> r -> r) -> GenericQ r -> GenericQ r
everything [Con] -> [Con] -> [Con]
forall a. [a] -> [a] -> [a]
(++) ([Con] -> (Con -> [Con]) -> a -> [Con]
forall a b r. (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
mkQ [] Con -> [Con]
getGadtCon)

isGadt :: [Con] -> Bool
isGadt :: [Con] -> Bool
isGadt [Con]
cons = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Con] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Con] -> Bool) -> [Con] -> Bool
forall a b. (a -> b) -> a -> b
$ (Con -> [Con]) -> [Con] -> [Con]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Con -> [Con]
forall a. Data a => a -> [Con]
getAllGadtCons [Con]
cons


constrInfoGadtC :: ConstructorInfo -> Con
constrInfoGadtC :: ConstructorInfo -> Con
constrInfoGadtC = ConstructorInfo -> Con
forall a. HasCallStack => a
undefined

-- ^ Get all fields of constructors
getAllConsFields :: [Con] -> [Type]
getAllConsFields :: [Con] -> [Kind]
getAllConsFields [Con]
cons = [Kind] -> [Kind]
forall a. Eq a => [a] -> [a]
nub ([Kind] -> [Kind]) -> [Kind] -> [Kind]
forall a b. (a -> b) -> a -> b
$ (Con -> [Kind]) -> [Con] -> [Kind]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Con -> [Kind]
getAllConFields [Con]
cons

getAllConFields :: Con -> [Type]
getAllConFields :: Con -> [Kind]
getAllConFields (NormalC Name
_ [BangType]
bts          ) = (BangType -> Kind) -> [BangType] -> [Kind]
forall a b. (a -> b) -> [a] -> [b]
map BangType -> Kind
forall a b. (a, b) -> b
snd [BangType]
bts
getAllConFields (RecC    Name
_ [VarBangType]
vbts         ) = (VarBangType -> Kind) -> [VarBangType] -> [Kind]
forall a b. (a -> b) -> [a] -> [b]
map (\(Name
_, Bang
_, Kind
x) -> Kind
x) [VarBangType]
vbts
getAllConFields (InfixC   BangType
bt1   Name
_    BangType
bt2) = [BangType -> Kind
forall a b. (a, b) -> b
snd BangType
bt1] [Kind] -> [Kind] -> [Kind]
forall a. [a] -> [a] -> [a]
++ [BangType -> Kind
forall a b. (a, b) -> b
snd BangType
bt2]
getAllConFields (ForallC  [TyVarBndr Specificity]
tvb   [Kind]
_  Con
con)   = let ns :: [Name]
ns = (TyVarBndr Specificity -> Name)
-> [TyVarBndr Specificity] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (TyVarBndr () -> Name
forall a. TyVarBndr a -> Name
getTVBName(TyVarBndr () -> Name)
-> (TyVarBndr Specificity -> TyVarBndr ())
-> TyVarBndr Specificity
-> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVarBndr Specificity -> TyVarBndr ()
forall flag. TyVarBndr flag -> TyVarBndr ()
voidTyVarBndrFlag) [TyVarBndr Specificity]
tvb
                                              in Con -> [Kind]
getAllConFields ([Name] -> Con -> Con
forall a. Data a => [Name] -> a -> a
replaceVarInForallTypeTrans [Name]
ns Con
con)
-- https://gitlab.haskell.org/ghc/ghc/-/issues/13885#note_476439
getAllConFields (GadtC    [Name]
_ [BangType]
_ Kind
_  ) = [Char] -> [Kind]
forall a. HasCallStack => [Char] -> a
error [Char]
"Should not use this to get fields of GADT"
getAllConFields (RecGadtC [Name]
_ [VarBangType]
_ Kind
_  ) = [Char] -> [Kind]
forall a. HasCallStack => [Char] -> a
error [Char]
"Should not use this to get fields of GADT"

{-| data T a1 a2 = Con1 a1 | Con2 a2 ...
 return [a1, a2], [Con1 a1, Con2 a2]
-}
#if __GLASGOW_HASKELL__ >= 900
getTyVarCons :: TypeName -> Q ([TyVarBndr ()], [Con])
#else
getTyVarCons :: TypeName -> Q ([TyVarBndr], [Con])
#endif
getTyVarCons :: Name -> Q ([TyVarBndr ()], [Con])
getTyVarCons Name
name = do
            Info
info <- Name -> Q Info
reify Name
name
            case Info
info of
              TyConI Dec
dec -> 
                case Dec
dec of
                  DataD    [Kind]
_ Name
_ [TyVarBndr BndrVis]
tvbs Maybe Kind
_ [Con]
cons [DerivClause]
_  -> ([TyVarBndr ()], [Con]) -> Q ([TyVarBndr ()], [Con])
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ((TyVarBndr BndrVis -> TyVarBndr ())
-> [TyVarBndr BndrVis] -> [TyVarBndr ()]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr BndrVis -> TyVarBndr ()
forall flag. TyVarBndr flag -> TyVarBndr ()
voidTyVarBndrFlag [TyVarBndr BndrVis]
tvbs, [Con]
cons)
                  NewtypeD [Kind]
_ Name
_ [TyVarBndr BndrVis]
tvbs Maybe Kind
_ Con
con  [DerivClause]
_  -> ([TyVarBndr ()], [Con]) -> Q ([TyVarBndr ()], [Con])
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ((TyVarBndr BndrVis -> TyVarBndr ())
-> [TyVarBndr BndrVis] -> [TyVarBndr ()]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr BndrVis -> TyVarBndr ()
forall flag. TyVarBndr flag -> TyVarBndr ()
voidTyVarBndrFlag [TyVarBndr BndrVis]
tvbs, [Con
con])
                  TySynD   Name
_ [TyVarBndr BndrVis]
_ Kind
_        -> [Char] -> Q ([TyVarBndr ()], [Con])
forall a. HasCallStack => [Char] -> a
error ([Char] -> Q ([TyVarBndr ()], [Con]))
-> [Char] -> Q ([TyVarBndr ()], [Con])
forall a b. (a -> b) -> a -> b
$ Name -> [Char]
forall a. Show a => a -> [Char]
show Name
name [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" is a type synonym and `TypeSynonymInstances' is not supported.\n"
                      [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"If you did not derive it then this is a bug, please report this bug to the author of `derive-topdown' package."
                  Dec
x -> do
                      [Char] -> Q ([TyVarBndr ()], [Con])
forall a. HasCallStack => [Char] -> a
error ([Char] -> Q ([TyVarBndr ()], [Con]))
-> [Char] -> Q ([TyVarBndr ()], [Con])
forall a b. (a -> b) -> a -> b
$ Dec -> [Char]
forall a. Ppr a => a -> [Char]
pprint (Dec
x :: Dec) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" is not a data or newtype definition."
              PrimTyConI Name
_ Int
_ Bool
_ -> ([TyVarBndr ()], [Con]) -> Q ([TyVarBndr ()], [Con])
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [])
              Info
x -> [Char] -> Q ([TyVarBndr ()], [Con])
forall a. HasCallStack => [Char] -> a
error ([Char] -> Q ([TyVarBndr ()], [Con]))
-> [Char] -> Q ([TyVarBndr ()], [Con])
forall a b. (a -> b) -> a -> b
$ Info -> [Char]
forall a. Show a => a -> [Char]
show Info
x [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" is not supported"

#if __GLASGOW_HASKELL__ >= 900
getTyVarFields :: TypeName -> Q ([TyVarBndr ()], [Type])
#else
getTyVarFields :: TypeName -> Q ([TyVarBndr], [Type])
#endif
getTyVarFields :: Name -> Q ([TyVarBndr ()], [Kind])
getTyVarFields Name
name = do
            Info
info <- Name -> Q Info
reify Name
name
            case Info
info of
              TyConI Dec
dec -> 
                case Dec
dec of
                  DataD    [Kind]
_ Name
_ [TyVarBndr BndrVis]
tvbs Maybe Kind
_ [Con]
cons [DerivClause]
_ ->
                    -- GADT needs to rebind type variables
                    -- See https://gitlab.haskell.org/ghc/ghc/-/issues/13885
                    if [Con] -> Bool
isGadt [Con]
cons
                      then do
                        DatatypeInfo
t <- Name -> Q DatatypeInfo
reifyDatatype Name
name
                        let vars :: [TyVarBndr ()]
vars = DatatypeInfo -> [TyVarBndr ()]
datatypeVars DatatypeInfo
t
                        let fields :: [Kind]
fields = (ConstructorInfo -> [Kind]) -> [ConstructorInfo] -> [Kind]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ConstructorInfo -> [Kind]
constructorFields (DatatypeInfo -> [ConstructorInfo]
datatypeCons DatatypeInfo
t)
                        ([TyVarBndr ()], [Kind]) -> Q ([TyVarBndr ()], [Kind])
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([TyVarBndr ()]
vars, [Kind]
fields)
                      else do
                        ([TyVarBndr ()], [Kind]) -> Q ([TyVarBndr ()], [Kind])
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (([TyVarBndr ()], [Kind]) -> Q ([TyVarBndr ()], [Kind]))
-> ([TyVarBndr ()], [Kind]) -> Q ([TyVarBndr ()], [Kind])
forall a b. (a -> b) -> a -> b
$ ((TyVarBndr BndrVis -> TyVarBndr ())
-> [TyVarBndr BndrVis] -> [TyVarBndr ()]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr BndrVis -> TyVarBndr ()
forall flag. TyVarBndr flag -> TyVarBndr ()
voidTyVarBndrFlag [TyVarBndr BndrVis]
tvbs, [Con] -> [Kind]
getAllConsFields [Con]
cons)
                  NewtypeD [Kind]
_ Name
_ [TyVarBndr BndrVis]
tvbs Maybe Kind
_ Con
con  [DerivClause]
_  -> ([TyVarBndr ()], [Kind]) -> Q ([TyVarBndr ()], [Kind])
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ((TyVarBndr BndrVis -> TyVarBndr ())
-> [TyVarBndr BndrVis] -> [TyVarBndr ()]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr BndrVis -> TyVarBndr ()
forall flag. TyVarBndr flag -> TyVarBndr ()
voidTyVarBndrFlag [TyVarBndr BndrVis]
tvbs, [Con] -> [Kind]
getAllConsFields [Con
con])
                  TySynD   Name
_ [TyVarBndr BndrVis]
_ Kind
_        -> [Char] -> Q ([TyVarBndr ()], [Kind])
forall a. HasCallStack => [Char] -> a
error ([Char] -> Q ([TyVarBndr ()], [Kind]))
-> [Char] -> Q ([TyVarBndr ()], [Kind])
forall a b. (a -> b) -> a -> b
$ Name -> [Char]
forall a. Show a => a -> [Char]
show Name
name [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" is a type synonym and `TypeSynonymInstances' is not supported.\n"
                      [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"If you did not derive it then this is a bug, please report this bug to the author of `derive-topdown' package."
                  Dec
x -> do
                      [Char] -> Q ([TyVarBndr ()], [Kind])
forall a. HasCallStack => [Char] -> a
error ([Char] -> Q ([TyVarBndr ()], [Kind]))
-> [Char] -> Q ([TyVarBndr ()], [Kind])
forall a b. (a -> b) -> a -> b
$ Dec -> [Char]
forall a. Ppr a => a -> [Char]
pprint (Dec
x :: Dec) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" is not a data or newtype definition."
              Info
_ -> [Char] -> Q ([TyVarBndr ()], [Kind])
forall a. HasCallStack => [Char] -> a
error ([Char] -> Q ([TyVarBndr ()], [Kind]))
-> [Char] -> Q ([TyVarBndr ()], [Kind])
forall a b. (a -> b) -> a -> b
$ [Char]
"Cannot generate instances for " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
forall a. Show a => a -> [Char]
show Name
name

getTypeConstructor :: Type -> Type
getTypeConstructor :: Kind -> Kind
getTypeConstructor (AppT Kind
a1 Kind
_) = Kind -> Kind
getTypeConstructor Kind
a1
getTypeConstructor Kind
a = Kind
a

reifyTypeParameters :: Name -> Q [Name]
reifyTypeParameters :: Name -> Q [Name]
reifyTypeParameters Name
tn = do 
                Info
info <- Name -> Q Info
reify Name
tn
                case Info
info of
                  TyConI (DataD [Kind]
_ Name
_ [TyVarBndr BndrVis]
tvb Maybe Kind
_ [Con]
_ [DerivClause]
_)    -> [Name] -> Q [Name]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Name] -> Q [Name]) -> [Name] -> Q [Name]
forall a b. (a -> b) -> a -> b
$ (TyVarBndr BndrVis -> Name) -> [TyVarBndr BndrVis] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr BndrVis -> Name
forall a. TyVarBndr a -> Name
getTVBName [TyVarBndr BndrVis]
tvb
                  TyConI (NewtypeD [Kind]
_ Name
_ [TyVarBndr BndrVis]
tvb Maybe Kind
_ Con
_ [DerivClause]
_) -> [Name] -> Q [Name]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Name] -> Q [Name]) -> [Name] -> Q [Name]
forall a b. (a -> b) -> a -> b
$ (TyVarBndr BndrVis -> Name) -> [TyVarBndr BndrVis] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr BndrVis -> Name
forall a. TyVarBndr a -> Name
getTVBName [TyVarBndr BndrVis]
tvb
                  Info
_                             -> [Char] -> Q [Name]
forall a. HasCallStack => [Char] -> a
error [Char]
"impossible case in reifyTypeParameters"
              
data DecTyType = Data | Newtype | TypeSyn | BuiltIn deriving (Int -> DecTyType -> [Char] -> [Char]
[DecTyType] -> [Char] -> [Char]
DecTyType -> [Char]
(Int -> DecTyType -> [Char] -> [Char])
-> (DecTyType -> [Char])
-> ([DecTyType] -> [Char] -> [Char])
-> Show DecTyType
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> DecTyType -> [Char] -> [Char]
showsPrec :: Int -> DecTyType -> [Char] -> [Char]
$cshow :: DecTyType -> [Char]
show :: DecTyType -> [Char]
$cshowList :: [DecTyType] -> [Char] -> [Char]
showList :: [DecTyType] -> [Char] -> [Char]
Show, Int -> DecTyType
DecTyType -> Int
DecTyType -> [DecTyType]
DecTyType -> DecTyType
DecTyType -> DecTyType -> [DecTyType]
DecTyType -> DecTyType -> DecTyType -> [DecTyType]
(DecTyType -> DecTyType)
-> (DecTyType -> DecTyType)
-> (Int -> DecTyType)
-> (DecTyType -> Int)
-> (DecTyType -> [DecTyType])
-> (DecTyType -> DecTyType -> [DecTyType])
-> (DecTyType -> DecTyType -> [DecTyType])
-> (DecTyType -> DecTyType -> DecTyType -> [DecTyType])
-> Enum DecTyType
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: DecTyType -> DecTyType
succ :: DecTyType -> DecTyType
$cpred :: DecTyType -> DecTyType
pred :: DecTyType -> DecTyType
$ctoEnum :: Int -> DecTyType
toEnum :: Int -> DecTyType
$cfromEnum :: DecTyType -> Int
fromEnum :: DecTyType -> Int
$cenumFrom :: DecTyType -> [DecTyType]
enumFrom :: DecTyType -> [DecTyType]
$cenumFromThen :: DecTyType -> DecTyType -> [DecTyType]
enumFromThen :: DecTyType -> DecTyType -> [DecTyType]
$cenumFromTo :: DecTyType -> DecTyType -> [DecTyType]
enumFromTo :: DecTyType -> DecTyType -> [DecTyType]
$cenumFromThenTo :: DecTyType -> DecTyType -> DecTyType -> [DecTyType]
enumFromThenTo :: DecTyType -> DecTyType -> DecTyType -> [DecTyType]
Enum, DecTyType -> DecTyType -> Bool
(DecTyType -> DecTyType -> Bool)
-> (DecTyType -> DecTyType -> Bool) -> Eq DecTyType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DecTyType -> DecTyType -> Bool
== :: DecTyType -> DecTyType -> Bool
$c/= :: DecTyType -> DecTyType -> Bool
/= :: DecTyType -> DecTyType -> Bool
Eq)

decType :: Name -> Q DecTyType
decType :: Name -> Q DecTyType
decType Name
name = do
         Info
info <- Name -> Q Info
reify Name
name
         case Info
info of
           TyConI Dec
dec -> case Dec
dec of
              DataD [Kind]
_ Name
_ [TyVarBndr BndrVis]
_ Maybe Kind
_ [Con]
_ [DerivClause]
_   -> DecTyType -> Q DecTyType
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return DecTyType
Data
              NewtypeD [Kind]
_ Name
_ [TyVarBndr BndrVis]
_ Maybe Kind
_ Con
_ [DerivClause]
_ -> DecTyType -> Q DecTyType
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return DecTyType
Newtype
              TySynD Name
_ [TyVarBndr BndrVis]
_ Kind
_ -> DecTyType -> Q DecTyType
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return DecTyType
TypeSyn
              Dec
_ -> [Char] -> Q DecTyType
forall a. HasCallStack => [Char] -> a
error ([Char] -> Q DecTyType) -> [Char] -> Q DecTyType
forall a b. (a -> b) -> a -> b
$ [Char]
"not a type declaration: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
forall a. Show a => a -> [Char]
show Name
name
           PrimTyConI Name
_ Int
_ Bool
_ -> DecTyType -> Q DecTyType
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return DecTyType
BuiltIn
           Info
_ ->  [Char] -> Q DecTyType
forall a. HasCallStack => [Char] -> a
error ([Char] -> Q DecTyType) -> [Char] -> Q DecTyType
forall a b. (a -> b) -> a -> b
$ [Char]
"not a type declaration: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
forall a. Show a => a -> [Char]
show Name
name 


getTypeNames :: Type -> [Name]
getTypeNames :: Kind -> [Name]
getTypeNames (ForallT [TyVarBndr Specificity]
_ [Kind]
_ Kind
t) = Kind -> [Name]
getTypeNames Kind
t
getTypeNames (ConT Name
n) = [Name
n]
getTypeNames (AppT Kind
t1 Kind
t2) = Kind -> [Name]
getTypeNames Kind
t1 [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ Kind -> [Name]
getTypeNames Kind
t2
getTypeNames Kind
_ = []

third :: (a, b, c) -> c
third :: forall a b c. (a, b, c) -> c
third (a
_,b
_,c
c) = c
c

expandSynsAndGetTypeNames :: [Type] -> Q [TypeName]
expandSynsAndGetTypeNames :: [Kind] -> Q [Name]
expandSynsAndGetTypeNames [Kind]
ts = do
                          [Kind]
ts' <- (Kind -> Q Kind) -> [Kind] -> Q [Kind]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Kind -> Q Kind
noWarnExpandSynsWith [Kind]
ts
                          [Name] -> Q [Name]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Name] -> Q [Name]) -> [Name] -> Q [Name]
forall a b. (a -> b) -> a -> b
$ (Kind -> [Name]) -> [Kind] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Kind -> [Name]
getTypeNames [Kind]
ts'

getCompositeTypeNames :: Con -> Q [TypeName]
getCompositeTypeNames :: Con -> Q [Name]
getCompositeTypeNames (NormalC Name
_ [BangType]
bts) = [Kind] -> Q [Name]
expandSynsAndGetTypeNames ((BangType -> Kind) -> [BangType] -> [Kind]
forall a b. (a -> b) -> [a] -> [b]
map BangType -> Kind
forall a b. (a, b) -> b
snd [BangType]
bts)
getCompositeTypeNames (RecC Name
_ [VarBangType]
vbts) = [Kind] -> Q [Name]
expandSynsAndGetTypeNames ((VarBangType -> Kind) -> [VarBangType] -> [Kind]
forall a b. (a -> b) -> [a] -> [b]
map VarBangType -> Kind
forall a b c. (a, b, c) -> c
third [VarBangType]
vbts)
getCompositeTypeNames (InfixC BangType
st1 Name
_ BangType
st2) = [Kind] -> Q [Name]
expandSynsAndGetTypeNames ((BangType -> Kind) -> [BangType] -> [Kind]
forall a b. (a -> b) -> [a] -> [b]
map BangType -> Kind
forall a b. (a, b) -> b
snd [BangType
st1 , BangType
st2])
getCompositeTypeNames (ForallC [TyVarBndr Specificity]
_ [Kind]
_ Con
con) = Con -> Q [Name]
getCompositeTypeNames Con
con
getCompositeTypeNames (GadtC [Name]
_ [BangType]
bangtype Kind
_) = [Kind] -> Q [Name]
expandSynsAndGetTypeNames ((BangType -> Kind) -> [BangType] -> [Kind]
forall a b. (a -> b) -> [a] -> [b]
map BangType -> Kind
forall a b. (a, b) -> b
snd [BangType]
bangtype)
getCompositeTypeNames (RecGadtC [Name]
_ [VarBangType]
bangtypes Kind
_) = [Kind] -> Q [Name]
expandSynsAndGetTypeNames ((VarBangType -> Kind) -> [VarBangType] -> [Kind]
forall a b. (a -> b) -> [a] -> [b]
map VarBangType -> Kind
forall a b c. (a, b, c) -> c
third [VarBangType]
bangtypes)

{-
Here, I just replace forall type into Any type since in the deriving clause generation
process, we cannot really do anything about the quantified type vars. 
if @data C b = C (forall a. Show a => a) b@ need to derive Eq, it will failed anyway. 
if user needs to derive @Show@ for @C@ the type @a@ does not matter here. We just need 
@b@ in the context
-}
replace_var_in_forall_type :: [Name] -> Type -> Type
replace_var_in_forall_type :: [Name] -> Kind -> Kind
replace_var_in_forall_type [Name]
ns v :: Kind
v@(VarT Name
n) = if Name
n Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
ns then Name -> Kind
ConT ''Any else Kind
v
replace_var_in_forall_type [Name]
_ Kind
v = Kind
v

replaceVarInForallTypeTrans :: Data a => [Name] -> a -> a
replaceVarInForallTypeTrans :: forall a. Data a => [Name] -> a -> a
replaceVarInForallTypeTrans [Name]
ns = (forall a. Data a => a -> a) -> forall a. Data a => a -> a
everywhere ((Kind -> Kind) -> a -> a
forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
mkT ([Name] -> Kind -> Kind
replace_var_in_forall_type [Name]
ns))

reset_forall_vars :: Type -> Type
reset_forall_vars :: Kind -> Kind
reset_forall_vars (ForallT [TyVarBndr Specificity]
bs [Kind]
_ Kind
t) = let bns :: [Name]
bns = (TyVarBndr Specificity -> Name)
-> [TyVarBndr Specificity] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (TyVarBndr () -> Name
forall a. TyVarBndr a -> Name
getTVBName(TyVarBndr () -> Name)
-> (TyVarBndr Specificity -> TyVarBndr ())
-> TyVarBndr Specificity
-> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
.TyVarBndr Specificity -> TyVarBndr ()
forall flag. TyVarBndr flag -> TyVarBndr ()
voidTyVarBndrFlag) [TyVarBndr Specificity]
bs
                                         in [Name] -> Kind -> Kind
forall a. Data a => [Name] -> a -> a
replaceVarInForallTypeTrans [Name]
bns Kind
t
#if __GLASGOW_HASKELL__ >= 810
reset_forall_vars (ForallVisT [TyVarBndr ()]
bs Kind
t) = let bns :: [Name]
bns = (TyVarBndr () -> Name) -> [TyVarBndr ()] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr () -> Name
forall a. TyVarBndr a -> Name
getTVBName [TyVarBndr ()]
bs
                                         in [Name] -> Kind -> Kind
forall a. Data a => [Name] -> a -> a
replaceVarInForallTypeTrans [Name]
bns Kind
t 
#endif
reset_forall_vars Kind
v = Kind
v

replaceForallTWithAny :: Type -> Type
replaceForallTWithAny :: Kind -> Kind
replaceForallTWithAny = (forall a. Data a => a -> a) -> forall a. Data a => a -> a
everywhere ((Kind -> Kind) -> a -> a
forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
mkT Kind -> Kind
reset_forall_vars)