Use Template Haskell to generate instance recursively

Question

In GenericPretty, there is an Out class with a default implementation by using GHC.Generic magic.

As you can see that I defined Person data type, and if I want to implement Out class I have to write 3 times manually since Person used Address and Names data types which should be also the instances of Out class.

I want to generate the instance declaration automatically with Template Haskell. The procedure seems simple.

1, Generate instance A for Person and seek the types which are used to define Person.

2, If the type used to define Person is not an instance A, generate it recursively.

However, gen function will not work. The code generation will not stop, I am not sure why. it could be the problem with mapM if you comment it out, the last line in gen will work.

{-# 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

You have some incomplete function definitions (e.g. type1, tvbName, getTyVarCons) and I am running into that.

I inserted a trace statement in DerivingTopDown.hs at the entry to gen:

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

and then loaded this file into ghci:

{-# LANGUAGE TemplateHaskell #-}
import DerivingTopDown
f

and got the following output:

=== 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.

So it recursed down to GHC.Base.String and then failed in getTyVarCons because the dec for this type is:

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

which isn't handled by the inner case statement in getTyVarCons.