{-# LANGUAGE TemplateHaskell, TypeOperators #-}moduleText.Boomerang.TH(derivePrinterParsers)whereimportControl.Monad(liftM,replicateM)importLanguage.Haskell.THimportText.Boomerang.HStack((:-)(..),arg)importText.Boomerang.Prim(xpure,PrinterParser)-- | Derive routers for all constructors in a datatype. For example: ---- @$(derivePrinterParsers \'\'Sitemap)@derivePrinterParsers::Name->Q[Dec]derivePrinterParsersname=doinfo<-reifynamecaseinfoofTyConI(DataD_tNametBindscons_)->concat`liftM`mapM(derivePrinterParser(tName,tBinds))consTyConI(NewtypeD_tNametBindscon_)->derivePrinterParser(tName,tBinds)con_->fail$showname++" is not a datatype."-- Derive a router for a single constructor.derivePrinterParser::(Name,[TyVarBndr])->Con->Q[Dec]derivePrinterParser(tName,tParams)con=caseconofNormalCnametys->goname(mapsndtys)RecCnametys->goname(map(\(_,_,ty)->ty)tys)_->dorunIO$putStrLn$"Skipping unsupported constructor "++show(conNamecon)return[]wheretakeName(PlainTVn)=ntakeName(KindedTVn_)=ngonametys=doletname'=mkPrinterParserNamenamelettok'=mkName"tok"lete'=mkName"e"letppType=AppT(AppT(ConT''PrinterParser)(VarTe'))(VarTtok')letr'=mkName"r"letinT=foldr(\ab->AppT(AppT(ConT''(:-))a)b)(VarTr')tysletoutT=AppT(AppT(ConT''(:-))(foldlAppT(ConTtName)(map(VarT.takeName)tParams)))(VarTr')runIO$putStrLn$"Introducing router "++nameBasename'++"."expr<-[|xpure$(deriveConstructorname(lengthtys))$(deriveDestructornametys)|]return[SigDname'(ForallT(mapPlainTV([tok',e',r']++(maptakeNametParams)))[](AppT(AppTppTypeinT)outT)),FunDname'[Clause[](NormalBexpr)[]]]-- Derive the contructor part of a router.deriveConstructor::Name->Int->QExpderiveConstructornamearity=[|$(mkarity)$(conEname)|]wheremk::Int->ExpQmk0=[|(:-)|]mkn=[|arg$(mk(n-1))|]-- Derive the destructor part of a router.deriveDestructor::Name->[Type]->QExpderiveDestructornametys=do-- Introduce some namesx<-newName"x"r<-newName"r"fieldNames<-replicateM(lengthtys)(newName"a")-- Figure out the names of some constructorsnothing<-[|Nothing|]ConEjust<-[|Just|]ConEleft<-[|Left|]ConEright<-[|Right|]ConEcons<-[|(:-)|]letconPat=ConPname(mapVarPfieldNames)letokBody=ConEjust`AppE`foldr(\ht->ConEcons`AppE`VarEh`AppE`t)(VarEr)fieldNamesletokCase=Match(ConPcons[conPat,VarPr])(NormalBokBody)[]letnStr=shownameletfailCase=MatchWildP(NormalBnothing)[]return$LamE[VarPx](CaseE(VarEx)[okCase,failCase])-- Derive the name of a router based on the name of the constructor in question.mkPrinterParserName::Name->NamemkPrinterParserNamename=mkName('r':nameBasename)-- Retrieve the name of a constructor.conName::Con->NameconNamecon=caseconofNormalCname_->nameRecCname_->nameInfixC_name_->nameForallC__con'->conNamecon'