{-# LANGUAGE TemplateHaskell #-}
module Data.Derive.TopDown.Instance (instance_, instances, instancess) where

import Data.Derive.TopDown.Lib
import Language.Haskell.TH
import Language.Haskell.TH.Syntax hiding (lift)
import qualified GHC.Generics as G
import Control.Monad
import Control.Monad.Trans
import Control.Monad.State
import Data.List (foldl')
import Data.Primitive.Types

genEmptyInstanceDecl :: ClassName -> TypeName -> StateT [Type] Q [Dec]
genEmptyInstanceDecl :: ClassName -> ClassName -> StateT [Type] Q [Dec]
genEmptyInstanceDecl ClassName
cn ClassName
tn = do
                   ([TyVarBndr]
tvbs,[Con]
cons) <- ClassName -> ClassName -> StateT [Type] Q ([TyVarBndr], [Con])
getTyVarCons ClassName
cn ClassName
tn
                   Maybe Type
classContext <- Q (Maybe Type) -> StateT [Type] Q (Maybe Type)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q (Maybe Type) -> StateT [Type] Q (Maybe Type))
-> Q (Maybe Type) -> StateT [Type] Q (Maybe Type)
forall a b. (a -> b) -> a -> b
$ ClassName -> ClassName -> Q (Maybe Type)
generateClassContext ClassName
cn ClassName
tn
                   let typeNames :: [ClassName]
typeNames = (TyVarBndr -> ClassName) -> [TyVarBndr] -> [ClassName]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> ClassName
getTVBName [TyVarBndr]
tvbs
                   Type
instanceType <- Q Type -> StateT [Type] Q Type
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q Type -> StateT [Type] Q Type) -> Q Type -> StateT [Type] Q Type
forall a b. (a -> b) -> a -> b
$ (Q Type -> Q Type -> Q Type) -> Q Type -> [Q Type] -> Q Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Q Type -> Q Type -> Q Type
appT (ClassName -> Q Type
conT ClassName
tn) ([Q Type] -> Q Type) -> [Q Type] -> Q Type
forall a b. (a -> b) -> a -> b
$ (ClassName -> Q Type) -> [ClassName] -> [Q Type]
forall a b. (a -> b) -> [a] -> [b]
map ClassName -> Q Type
varT [ClassName]
typeNames
                   -- Stop generating further instances

                   -- 1. it is already a member of that type class

                   -- 2. we have already generated it, which is kind of same with case 1

                   -- 3. for GHC.Generic, if it is a primitive type like Int, Double

                   Bool
isMember <- Q Bool -> StateT [Type] Q Bool
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q Bool -> StateT [Type] Q Bool) -> Q Bool -> StateT [Type] Q Bool
forall a b. (a -> b) -> a -> b
$ ClassName -> [Type] -> Q Bool
isInstance' ClassName
cn [Type
instanceType]              
                   Bool
isPrimitive <-Q Bool -> StateT [Type] Q Bool
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q Bool -> StateT [Type] Q Bool) -> Q Bool -> StateT [Type] Q Bool
forall a b. (a -> b) -> a -> b
$ ClassName -> [Type] -> Q Bool
isInstance ''Prim [Type
instanceType]
                   let isGeneric :: Bool
isGeneric = ''G.Generic ClassName -> ClassName -> Bool
forall a. Eq a => a -> a -> Bool
== ClassName
cn             
                   [Type]
table <- StateT [Type] Q [Type]
forall s (m :: * -> *). MonadState s m => m s
get
                   if Bool
isMember Bool -> Bool -> Bool
|| Type -> [Type] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Type
instanceType [Type]
table Bool -> Bool -> Bool
|| (Bool
isPrimitive Bool -> Bool -> Bool
&& Bool
isGeneric)
                     then [Dec] -> StateT [Type] Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return []
                     else do
                       let context :: [Type]
context = case Maybe Type
classContext of
                                       Maybe Type
Nothing -> []
                                       Just Type
cc -> if Bool
isGeneric then [] else [Type
cc]
#if __GLASGOW_HASKELL__> 710                                       
                       let c :: [Dec]
c = [Maybe Overlap -> [Type] -> Type -> [Dec] -> Dec
InstanceD Maybe Overlap
forall a. Maybe a
Nothing [Type]
context (Type -> Type -> Type
AppT (ClassName -> Type
ConT ClassName
cn) Type
instanceType) []]
#else
                       let c = [InstanceD context (AppT (ConT cn) instanceType) []]
#endif
                       ([Type] -> [Type]) -> StateT [Type] Q ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (Type
instanceTypeType -> [Type] -> [Type]
forall a. a -> [a] -> [a]
:)
                       [ClassName]
names <- Q [ClassName] -> StateT [Type] Q [ClassName]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q [ClassName] -> StateT [Type] Q [ClassName])
-> Q [ClassName] -> StateT [Type] Q [ClassName]
forall a b. (a -> b) -> a -> b
$ ([[ClassName]] -> [ClassName]) -> Q [[ClassName]] -> Q [ClassName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[ClassName]] -> [ClassName]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[ClassName]] -> Q [ClassName])
-> Q [[ClassName]] -> Q [ClassName]
forall a b. (a -> b) -> a -> b
$ (Con -> Q [ClassName]) -> [Con] -> Q [[ClassName]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Con -> Q [ClassName]
getCompositeTypeNames [Con]
cons
                       [[Dec]]
xs <- (ClassName -> StateT [Type] Q [Dec])
-> [ClassName] -> StateT [Type] Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\ClassName
n -> ClassName -> ClassName -> StateT [Type] Q [Dec]
genEmptyInstanceDecl ClassName
cn ClassName
n) [ClassName]
names
                       [Dec] -> StateT [Type] Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> StateT [Type] Q [Dec]) -> [Dec] -> StateT [Type] Q [Dec]
forall a b. (a -> b) -> a -> b
$ [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Dec]]
xs [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
c

instance_ :: Name -- ^ class name

          -> Name -- ^ type name

          -> Q [Dec]
instance_ :: ClassName -> ClassName -> Q [Dec]
instance_ ClassName
cn ClassName
tn = StateT [Type] Q [Dec] -> [Type] -> Q [Dec]
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (ClassName -> ClassName -> StateT [Type] Q [Dec]
genEmptyInstanceDecl ClassName
cn ClassName
tn) []

instances :: [Name] -- ^ class names

          -> Name   -- ^ type name

          -> Q [Dec]
instances :: [ClassName] -> ClassName -> Q [Dec]
instances [ClassName]
cns ClassName
tn = ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ((ClassName -> Q [Dec]) -> [ClassName] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\ClassName
x -> ClassName -> ClassName -> Q [Dec]
instance_ ClassName
x ClassName
tn) [ClassName]
cns)

instancess :: [Name] -- ^ class names

           -> [Name] -- ^ type names

           -> Q [Dec]
instancess :: [ClassName] -> [ClassName] -> Q [Dec]
instancess [ClassName]
cns [ClassName]
tns = ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ((ClassName -> Q [Dec]) -> [ClassName] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\ClassName
x -> [ClassName] -> ClassName -> Q [Dec]
instances [ClassName]
cns ClassName
x) [ClassName]
tns)