{-|

Module      : Data.Derive.TopDown
Description : Help Haskellers derive class instances for composited data types.
Copyright   : (c) songzh
License     : BSD3
Maintainer  : Haskell.Zhang.Song@hotmail.com
Stability   : experimental

Class dependencies can be complex sometimes, such as numeric and monadic classes. Making instances of them can be very tedious. Functoins in this module will help you derive the specified class instance with all the superclass instances of it.  For using this module, you may need to enable the following langauge extensions: @TemplateHaskell@, @StandaloneDeriving@, @DeriveGeneric@, @DeriveDataTypeable@, @GeneralizedNewtypeDeriving@, @DeriveAnyClass@

You may also need to enable GHC options @-ddump-splices@. 

For example:

> data A = A
> deriving_superclasses ''Ord ''A

You wil get:

>    deriving_superclasses ''Ord ''A
>  ======>
>    deriving instance Ord A
>    deriving instance Eq A

'Eq' is automatically derived when 'Ord' is derived, since 'Eq' is a superclass of 'Ord'

> newtype IO_ a = IO_ (IO a)
> strategy_deriving_superclasses newtype_ ''MonadIO ''IO_ 

You will get:

>    strategy_deriving_superclasses newtype_ ''MonadIO ''IO_
>  ======>
>    deriving newtype instance MonadIO IO_
>    deriving newtype instance Monad IO_
>    deriving newtype instance Applicative IO_
>    deriving newtype instance Functor IO_

Appearently, @Functor f => Applicative f => Monad f => MonadIO f@

> newtype F32 = F32 Float
> newtype_deriving_superclasses ''RealFloat ''F32

You will get:

>    newtype_deriving_superclasses ''RealFloat ''F32
>  ======>
>    deriving newtype instance RealFloat F32
>    deriving newtype instance RealFrac F32
>    deriving newtype instance Real F32
>    deriving newtype instance Num F32
>    deriving newtype instance Ord F32
>    deriving newtype instance Eq F32
>    deriving newtype instance Fractional F32
>    deriving newtype instance Floating F32

Some of these examples are from [#13368](https://ghc.haskell.org/trac/ghc/ticket/13368).
-}

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

-- |Use newtype strategy to derive all the superclass instances.

newtype_deriving_superclasses :: Name -> Name -> Q [Dec]
newtype_deriving_superclasses = DerivStrategy -> Name -> Name -> Q [Dec]
strategy_deriving_superclasses DerivStrategy
NewtypeStrategy

-- |Abbreviation for @newtype_deriving_superclasses@.

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