Use Template Haskell to generate instance recursively - haskell

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.