{-# 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 Language.Haskell.TH.Datatype (
    ConstructorInfo(..),
    DatatypeInfo(..),
    reifyDatatype
    )

type ClassName = Name
type TypeName = Name

type ContextGenderator = ClassName -> TypeName -> Q Cxt

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 ()]
_ 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 ()]
_ 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 ()]
vars [FunDep]
_ [Dec]
_) [Dec]
_ 
            -> case [TyVarBndr ()] -> TyVarBndr ()
forall a. HasCallStack => [a] -> a
head [TyVarBndr ()]
vars of
#if __GLASGOW_HASKELL__ >= 900
                  KindedTV Name
_ ()
_ 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 ()
_ -> [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 ()]
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 () -> TyVarBndr ()) -> [TyVarBndr ()] -> [TyVarBndr ()]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr () -> TyVarBndr ()
forall flag. TyVarBndr flag -> TyVarBndr ()
voidTyVarBndrFlag [TyVarBndr ()]
tvbs, [Con]
cons)
                  NewtypeD [Kind]
_ Name
_ [TyVarBndr ()]
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 () -> TyVarBndr ()) -> [TyVarBndr ()] -> [TyVarBndr ()]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr () -> TyVarBndr ()
forall flag. TyVarBndr flag -> TyVarBndr ()
voidTyVarBndrFlag [TyVarBndr ()]
tvbs, [Con
con])
                  TySynD   Name
_ [TyVarBndr ()]
_ 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 ()]
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 () -> TyVarBndr ()) -> [TyVarBndr ()] -> [TyVarBndr ()]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr () -> TyVarBndr ()
forall flag. TyVarBndr flag -> TyVarBndr ()
voidTyVarBndrFlag [TyVarBndr ()]
tvbs, [Con] -> [Kind]
getAllConsFields [Con]
cons)
                  NewtypeD [Kind]
_ Name
_ [TyVarBndr ()]
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 () -> TyVarBndr ()) -> [TyVarBndr ()] -> [TyVarBndr ()]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr () -> TyVarBndr ()
forall flag. TyVarBndr flag -> TyVarBndr ()
voidTyVarBndrFlag [TyVarBndr ()]
tvbs, [Con] -> [Kind]
getAllConsFields [Con
con])
                  TySynD   Name
_ [TyVarBndr ()]
_ 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 ()]
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 () -> Name) -> [TyVarBndr ()] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr () -> Name
forall a. TyVarBndr a -> Name
getTVBName [TyVarBndr ()]
tvb
                  TyConI (NewtypeD [Kind]
_ Name
_ [TyVarBndr ()]
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 () -> Name) -> [TyVarBndr ()] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr () -> Name
forall a. TyVarBndr a -> Name
getTVBName [TyVarBndr ()]
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 ()]
_ 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 ()]
_ 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 ()]
_ 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)