{-# LANGUAGE TemplateHaskell #-}
module Data.Derive.TopDown.Standalone (
deriving_, derivings, derivingss, deriving_with_breaks
#if __GLASGOW_HASKELL__ >= 802
,strategy_deriving
,strategy_derivings
,strategy_derivingss
#endif
) 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
import Data.Typeable
#if __GLASGOW_HASKELL__ >= 802
genStandaloneDerivingDecl :: ClassName -> TypeName -> Maybe DerivStrategy -> [TypeName] -> StateT [Type] Q [Dec]
genStandaloneDerivingDecl cn tn st breaks = do
#else
genStandaloneDerivingDecl :: ClassName -> TypeName -> [TypeName] -> StateT [Type] Q [Dec]
genStandaloneDerivingDecl cn tn breaks = do
#endif
(tvbs,cons) <- getTyVarCons cn tn
classContext <- lift $ generateClassContext cn tn
let typeNames = map getTVBName tvbs
instanceType <- lift $ foldl' appT (conT tn) $ map varT typeNames
isMember <- lift $ isInstance' cn [instanceType]
isPrimitive <-lift $ isInstance' ''Prim [instanceType]
let isGeneric = ''G.Generic == cn
table <- get
if isMember || elem instanceType table || elem tn breaks ||
(isPrimitive && isGeneric) || (isGeneric && tn == ''Integer) ||
(cn == ''Typeable && isPrimitive) || (cn == ''Typeable && tn == ''Integer)
then return []
else do
let context = case classContext of
Nothing -> []
Just cc -> if isGeneric then [] else [cc]
#if __GLASGOW_HASKELL__ >= 802
declareType <- lift (decType tn)
let standaloneD = \strategy -> [StandaloneDerivD strategy context (AppT (ConT cn) instanceType)]
let c = if st == Nothing
then standaloneD Nothing
else case declareType of
Data -> case st of
Just NewtypeStrategy -> standaloneD Nothing
_ -> standaloneD st
_ -> standaloneD st
#else
let c = [StandaloneDerivD context (AppT (ConT cn) instanceType)]
#endif
modify (instanceType:)
names <- lift $ fmap concat $ mapM getCompositeTypeNames cons
#if __GLASGOW_HASKELL__ >= 802
xs <- mapM (\n -> genStandaloneDerivingDecl cn n st breaks) names
#else
xs <- mapM (\n -> genStandaloneDerivingDecl cn n breaks) names
#endif
return $ concat xs ++ c
deriving_ :: Name
-> Name
-> Q [Dec]
#if __GLASGOW_HASKELL__ >= 802
deriving_ cn tn = evalStateT (genStandaloneDerivingDecl cn tn Nothing []) []
#else
deriving_ cn tn = evalStateT (genStandaloneDerivingDecl cn tn []) []
#endif
deriving_with_breaks :: Name
-> Name
-> [Name]
-> Q [Dec]
#if __GLASGOW_HASKELL__ >= 802
deriving_with_breaks cn tn bs = evalStateT (genStandaloneDerivingDecl cn tn Nothing bs) []
#else
deriving_with_breaks cn tn bs = evalStateT (genStandaloneDerivingDecl cn tn bs) []
#endif
derivings :: [Name]
-> Name
-> Q [Dec]
derivings cns tn = fmap concat (mapM (\x -> deriving_ x tn) cns)
derivingss :: [Name]
-> [Name]
-> Q [Dec]
derivingss cns tns = fmap concat (mapM (\x -> derivings cns x) tns)
#if __GLASGOW_HASKELL__ >= 802
strategy_deriving :: DerivStrategy
-> Name
-> Name
-> Q [Dec]
strategy_deriving st cn tn = evalStateT (genStandaloneDerivingDecl cn tn (Just st) []) []
strategy_derivings :: DerivStrategy
-> [Name]
-> Name
-> Q [Dec]
strategy_derivings st cns tn = fmap concat $ (mapM (\x -> strategy_deriving st x tn) cns)
strategy_derivingss :: DerivStrategy
-> [Name]
-> [Name]
-> Q [Dec]
strategy_derivingss st cns tns = fmap concat $ (mapM (\x -> strategy_derivings st cns x) tns)
#endif