使用模板Haskell递归生成实例

在GenericPretty中，有一个Out类，它使用GHC.Generic magic实现了一个默认的实现

正如您所看到的，我定义了Person数据类型，如果我想实现Out类，我必须手动编写3次，因为Person使用了Address和Names数据类型，这些数据类型也应该是Out类的实例

我想用模板Haskell自动生成实例声明。程序似乎很简单

1、为Person生成实例并查找用于定义Person的类型。 2，如果用于定义Person的类型不是实例A，则递归生成它。 但是，gen功能将不起作用。代码生成不会停止，我不知道为什么。这可能是mapM的问题，如果您将其注释掉，gen中的最后一行将正常工作

{-# LANGUAGE CPP, TemplateHaskell,StandaloneDeriving, DeriveGeneric, DeriveDataTypeable  #-}
module DerivingTopDown where 
import Language.Haskell.TH
import GHC.Generics
import Data.Data
import Data.Proxy
import Control.Monad
import Text.PrettyPrint.GenericPretty
import Data.List
import Debug.Trace
import Control.Monad.State
import Control.Monad.Trans

data Person  = Person Names Address 
             | Student Names Address 
                       deriving (Show, Generic, Eq, Ord , Data,Typeable)
data Names   = Names String 
                       deriving (Show, Generic, Eq, Ord, Data, Typeable)
data Address = Address String 
                       deriving (Show, Generic, Eq, Ord, Typeable, Data)

{-
data T a b = C1 a | C2 b
instance (Out a , Out b) => Out (T a b)

([],[NormalC Main.Person  [(NotStrict,ConT Main.Names),(NotStrict,ConT Main.Address)],
      NormalC Main.Student [(NotStrict,ConT Main.Names),(NotStrict,ConT Main.Address)]])
-}
-- instance Out Address
-- instance Out Names
-- instance Out Person
---      class name -> type name, use a stateT to store a dictionary
gen :: Name -> Name -> StateT [Name] Q [Dec]
gen cla typ = do
    (tys, cons) <- lift (getTyVarCons typ)
    let typeNames = map tvbName tys
    let instanceType = foldl' appT (conT typ) $ map varT typeNames
    let context = applyContext cla typeNames
    let decltyps = (conT cla `appT` instanceType)
    isIns <- lift (typ `isInstanceOf` cla)
    table <- get
    if isIns || elem typ table -- if it is already the instnace or we have generated it return []
       then return []
       else  do
          dec <-  lift $ fmap (:[]) $ instanceD context decltyps []
          modify (typ:)  -- add the generated type to dictionary
          let names = concatMap getSubType cons
          xs <-  mapM (\n -> gen cla n) names
          return $ concat xs ++ dec
          --return dec -- works fine if do not generate recursively by using mapM

f = (fmap fst ((runStateT $ gen ''Out ''Person) []))

getSubType :: Con -> [Name]
getSubType (NormalC n sts) = map type1 (map snd sts)

type1 :: Type -> Name
type1 (ConT n) = n

tvbName :: TyVarBndr -> Name
tvbName (PlainTV  name  ) = name
tvbName (KindedTV name _) = name


applyContext :: Name -> [Name] -> Q [Pred]
applyContext con typeNames = return (map apply typeNames)
                         where apply t = ClassP con [VarT t]

isInstanceOf :: Name -> Name -> Q Bool
isInstanceOf ty inst = do 
                t1 <- conT (ty)
                isInstance inst [t1]

getTyVarCons :: Name -> Q ([TyVarBndr], [Con])
getTyVarCons name = do
        info <- reify name
        case info of 
             TyConI dec ->
                case dec of
                     DataD    _ _ tvbs cons _ -> return (tvbs,cons)
                     NewtypeD _ _ tvbs con  _ -> return (tvbs,[con])

-- pp =   $(stringE . show =<< getCons ''Person)

pp1 name = stringE.show =<< name

isi name = do
    t1 <- [t| $name  |]
    isInstance ''Out [t1]

{-#语言CPP，TemplateHaskell，独立派生，派生通用，派生数据类型化}
模块导出自上而下在哪里
导入语言.Haskell.TH
进口GHC.仿制药
导入数据
导入数据。代理
进口管制
导入Text.PrettyPrint.GenericPretty
导入数据。列表
导入调试跟踪
进口控制单体状态
进口管制.Monad.Trans
data Person=人名地址
|学生姓名地址
派生（显示、通用、等式、Ord、数据、可键入）
数据名称=名称字符串
派生（显示、通用、等式、Ord、数据、可键入）
数据地址=地址字符串
派生（显示、通用、等式、Ord、可键入、数据）
{-
数据T a b=C1 a | C2 b
实例（Out a，Out b）=>Out（ta b）
（[]，[NormalC Main.Person[（NotStrict，ConT Main.Names），（NotStrict，ConT Main.Address）]，
NormalC Main.Student[（NotStrict，ConT Main.Names），（NotStrict，ConT Main.Address）]）
-}
--实例输出地址
--实例输出名称
--举例说明人
---类名->类型名，使用stateT存储字典
gen:：Name->Name->StateT[Name]Q[Dec]
gen cla typ=do
（tys，cons）您有一些不完整的函数定义（例如，
type1
，
tvbName
，
getTyVarCons
），我遇到了这些

我在
gen
的条目中的
deringTopDown.hs
中插入了跟踪语句：

import Debug.Trace
...
gen cla typ = trace ("=== typ: " ++ show typ) $ do
  ...

然后将此文件加载到
ghci
：

{-# LANGUAGE TemplateHaskell #-}
import DerivingTopDown
f

并得到以下输出：

=== typ: DerivingTopDown.Person
=== typ: DerivingTopDown.Names
=== typ: GHC.Base.String

th.hs:1:1:
    Exception when trying to run compile-time code:
      DerivingTopDown.hs:(80,17)-(82,68): Non-exhaustive patterns in case

    Code: f
Failed, modules loaded: DerivingTopDown.

因此它递归到
GHC.Base.String
，然后在
getTyVarCons
中失败，因为这种类型的
dec
是：

dec = TySynD GHC.Base.String [] (AppT ListT (ConT GHC.Types.Char))

在
getTyVarCons
中，哪些不是由内部case语句处理的，您可以显示您正在扩展的拼接吗？当我在另一个模块中使用
f
时，它会递归到
GHC.Base.String
，然后在
getTyVarCons
中遇到不匹配的情况。谢谢。我认为它不应该走这么远，因为String已经是Out类的实例了。它应该返回[]。我会设法弄明白的。谢谢你，伙计，让getTyVarCons回来（[]，[]）就行了。