module Data.Derive.Superclass
(deriving_superclasses,
#if __GLASGOW_HASKELL__ >= 802
strategy_deriving_superclasses,
newtype_deriving_superclasses,
gnds
#endif
)where
import Data.Derive.TopDown.Lib
import Language.Haskell.TH
import Language.Haskell.TH.Lib
import Debug.Trace
import Control.Monad
import Data.List
import Control.Monad.Trans.State
import Control.Monad.Trans
import Data.Maybe
import Language.Haskell.TH.Ppr
isHigherOrderClass :: Name -> Q Bool
isHigherOrderClass :: Name -> Q Bool
isHigherOrderClass Name
ty = do
Info
cla <- Name -> Q Info
reify Name
ty
case Info
cla of
ClassI (ClassD Cxt
_ Name
_ [TyVarBndr]
vars [FunDep]
_ [Dec]
_) [Dec]
_ -> do
#if __GLASGOW_HASKELL__ > 810
let (KindedTV _ _ k) = head vars
#else
let (KindedTV Name
_ Kind
k) = [TyVarBndr] -> TyVarBndr
forall a. [a] -> a
head [TyVarBndr]
vars
#endif
if Kind
k Kind -> Kind -> Bool
forall a. Eq a => a -> a -> Bool
== Kind
StarT
then Bool -> Q Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
else Bool -> Q Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
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
ty [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" is not a class"
deriving_superclasses :: Name -> Name -> Q [Dec]
deriving_superclasses :: Name -> Name -> Q [Dec]
deriving_superclasses Name
cn Name
tn = do
[Dec]
a <- StateT Cxt Q [Dec] -> Cxt -> Q [Dec]
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (Maybe DerivStrategy -> Name -> Name -> StateT Cxt Q [Dec]
deriving_superclasses'
#if __GLASGOW_HASKELL__ >= 802
Maybe DerivStrategy
forall a. Maybe a
Nothing
#endif
Name
cn Name
tn) []
[Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return [Dec]
a
#if __GLASGOW_HASKELL__ >= 802
strategy_deriving_superclasses :: DerivStrategy -> Name -> Name -> Q [Dec]
strategy_deriving_superclasses :: DerivStrategy -> Name -> Name -> Q [Dec]
strategy_deriving_superclasses DerivStrategy
st Name
cn Name
tn = do
[Dec]
a <- StateT Cxt Q [Dec] -> Cxt -> Q [Dec]
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (Maybe DerivStrategy -> Name -> Name -> StateT Cxt Q [Dec]
deriving_superclasses' (DerivStrategy -> Maybe DerivStrategy
forall a. a -> Maybe a
Just DerivStrategy
st) Name
cn Name
tn) []
[Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return [Dec]
a
newtype_deriving_superclasses :: Name -> Name -> Q [Dec]
newtype_deriving_superclasses = DerivStrategy -> Name -> Name -> Q [Dec]
strategy_deriving_superclasses DerivStrategy
NewtypeStrategy
gnds :: Name -> Name -> Q [Dec]
gnds = Name -> Name -> Q [Dec]
newtype_deriving_superclasses
#endif
#if __GLASGOW_HASKELL__ >= 802
deriving_superclasses' :: Maybe DerivStrategy -> Name -> Name -> StateT [Type] Q [Dec]
deriving_superclasses' :: Maybe DerivStrategy -> Name -> Name -> StateT Cxt Q [Dec]
deriving_superclasses' Maybe DerivStrategy
st Name
cn Name
tn = do
#else
deriving_superclasses' :: Name -> Name -> StateT [Type] Q [Dec]
deriving_superclasses' cn tn = do
#endif
([TyVarBndr]
tvbs,[Con]
cons) <- Name -> Name -> StateT Cxt Q ([TyVarBndr], [Con])
getTyVarCons Name
cn Name
tn
let tp :: Kind
tp = Kind -> Kind -> Kind
AppT (Name -> Kind
ConT Name
cn) (Name -> Kind
ConT Name
tn)
Cxt
types <- StateT Cxt Q Cxt
forall (m :: * -> *) s. Monad m => StateT s m s
get
Bool
isCnHighOrderClass <- Q Bool -> StateT Cxt Q Bool
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q Bool -> StateT Cxt Q Bool) -> Q Bool -> StateT Cxt Q Bool
forall a b. (a -> b) -> a -> b
$ Name -> Q Bool
isHigherOrderClass Name
cn
Maybe Kind
classContext <- if Bool
isCnHighOrderClass
then Q (Maybe Kind) -> StateT Cxt Q (Maybe Kind)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q (Maybe Kind) -> StateT Cxt Q (Maybe Kind))
-> Q (Maybe Kind) -> StateT Cxt Q (Maybe Kind)
forall a b. (a -> b) -> a -> b
$ Name -> Name -> Q (Maybe Kind)
generateClassContext Name
cn Name
tn
else Maybe Kind -> StateT Cxt Q (Maybe Kind)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Kind
forall a. Maybe a
Nothing
let Just Kind
a = Maybe Kind
classContext
let typeNames :: [Name]
typeNames = (TyVarBndr -> Name) -> [TyVarBndr] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Name
getTVBName [TyVarBndr]
tvbs
Bool
isIns <- Q Bool -> StateT Cxt Q Bool
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q Bool -> StateT Cxt Q Bool) -> Q Bool -> StateT Cxt Q Bool
forall a b. (a -> b) -> a -> b
$ Name -> Cxt -> Q Bool
isInstance' Name
cn [Name -> Kind
ConT Name
tn]
let context :: Cxt
context = Maybe Kind -> Cxt
forall a. Maybe a -> [a]
maybeToList Maybe Kind
classContext
if (Bool
isIns Bool -> Bool -> Bool
|| Kind -> Cxt -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Kind
tp Cxt
types)
then [Dec] -> StateT Cxt Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return []
else
do
[Dec]
topClassInstance <- [Dec] -> StateT Cxt Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return [Maybe DerivStrategy -> Cxt -> Kind -> Dec
StandaloneDerivD
#if __GLASGOW_HASKELL__ >= 802
Maybe DerivStrategy
st
#endif
Cxt
context Kind
tp]
(Cxt -> Cxt) -> StateT Cxt Q ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (Kind
tpKind -> Cxt -> Cxt
forall a. a -> [a] -> [a]
:)
Info
ci <- Q Info -> StateT Cxt Q Info
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q Info -> StateT Cxt Q Info) -> Q Info -> StateT Cxt Q Info
forall a b. (a -> b) -> a -> b
$ Name -> Q Info
reify Name
cn
case Info
ci of
ClassI (ClassD Cxt
ctx Name
_ [TyVarBndr]
_ [FunDep]
_ [Dec]
_) [Dec]
_ -> do
let classConTs :: Cxt
classConTs = (Kind -> Kind) -> Cxt -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map Kind -> Kind
getTypeConstructor Cxt
ctx
[Dec]
ss <- ([[Dec]] -> [Dec]) -> StateT Cxt Q [[Dec]] -> StateT Cxt Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Dec] -> [Dec]
forall a. Eq a => [a] -> [a]
nub([Dec] -> [Dec]) -> ([[Dec]] -> [Dec]) -> [[Dec]] -> [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.[[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat) (StateT Cxt Q [[Dec]] -> StateT Cxt Q [Dec])
-> StateT Cxt Q [[Dec]] -> StateT Cxt Q [Dec]
forall a b. (a -> b) -> a -> b
$ Cxt -> (Kind -> StateT Cxt Q [Dec]) -> StateT Cxt Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Cxt
classConTs ((Kind -> StateT Cxt Q [Dec]) -> StateT Cxt Q [[Dec]])
-> (Kind -> StateT Cxt Q [Dec]) -> StateT Cxt Q [[Dec]]
forall a b. (a -> b) -> a -> b
$ \(ConT Name
className) -> do
[Dec]
superclass_decls <- Maybe DerivStrategy -> Name -> Name -> StateT Cxt Q [Dec]
deriving_superclasses'
#if __GLASGOW_HASKELL__ >= 802
Maybe DerivStrategy
st
#endif
Name
className Name
tn
[Dec] -> StateT Cxt Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return [Dec]
superclass_decls
[Dec] -> StateT Cxt Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> StateT Cxt Q [Dec]) -> [Dec] -> StateT Cxt Q [Dec]
forall a b. (a -> b) -> a -> b
$ [Dec]
topClassInstance [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
ss