Question

在GenericPretty中，通过使用GHC.Generic magic，有一个Out类具有默认实现。

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

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

1，为Person生成实例A并寻找用于定义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]

Answer 1

您有一些不完整的功能定义（例如type1，tvbName，getTyVarCons），而且我遇到了这个问题。

我在DerivingTopDown.hs的条目{@ 1}}中插入了跟踪语句：

gen

然后将此文件加载到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))中的内部案例陈述处理。

使用Template Haskell以递归方式生成实例

1，为Person生成实例A并寻找用于定义Person的类型。

2，如果用于定义Person的类型不是实例A，则递归生成它。

1 个答案: