Используйте Template Haskell для рекурсивной генерации экземпляра.

Question

В GenericPretty есть класс Out с реализацией по умолчанию, использующей магию GHC.Generic.

Как вы можете видеть, я определил тип данных Person, и если я хочу реализовать класс Out, мне придется писать 3 раза вручную, поскольку Person использует типы данных Address и Names, которые также должны быть экземплярами класса Out.

Я хочу сгенерировать объявление экземпляра автоматически с шаблоном Haskell. Процедура кажется простой.

1. Сгенерируйте экземпляр A для 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]

Answer 1

У вас есть некоторые неполные определения функций (например, type1, tvbName, getTyVarCons) и я сталкиваюсь с этим.

Я вставил трассировку в DerivingTopDown.hs при входе в 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))

который не обрабатывается внутренним оператором case в getTyVarCons,