{-# LANGUAGE TemplateHaskell #-}{-|
Automatically derive 'Text.GRead.Gram' instances for data types.
/Note!/ This is not a complete implementation and will not work for all datatypes.
Unsupported are
* Multiple type arguments
* Tuple, Function, List types
* All primitive types (also when used in user defined types!)
Use with care.
-}moduleText.GRead.Derive(deriveGrammar,deriveSimpleGrammar)whereimportText.GRead.GrammarimportLanguage.AbstractSyntax.TTTASimportText.GRead.Derive.BindingGroupimportData.List(nub,foldl',foldl1')importData.Foldable(foldr')importData.Map(Map)importqualifiedData.MapasMap(insertWith,empty,toList)importControl.Monad(foldM)importLanguage.Haskell.THimportLanguage.Haskell.TH.Syntax{-|
Derive a 'Text.GRead.Gram' instance. This is a Template Haskell function. Usage example:
@
data T1 = C1 | C2 | C3
$(deriveGrammar ''T1)
@
-}deriveGrammar::Name->Q[Dec]deriveGrammarname=dobindingGroup<-getBindingGroupnamederiveGrammar'namebindingGroup{-|
Simpler version of 'deriveGrammar' that doesn't do binding group
calculations. Use this for large types without cyclic references to other
types.
For example, if you want to derive the 'HDYRM.Gram' for 'T3' and 'T4'
below, you will need the normal 'deriveGrammar'.
@
data T3 = T3 T4 | C3
data T4 = T4 T3 | C4
@
-}deriveSimpleGrammar::Name->Q[Dec]deriveSimpleGrammarname=deriveGrammar'name[]deriveGrammar'::Name->BindingGroup->Q[Dec]deriveGrammar'namebindingGroup=do(UserD_argscs)<-getUserTypenamebody<-mkBodynamecsbindingGroupreturn[InstanceD(mkContextcs)(mkInstanceTypenameargs)body]mkContext::[Con]->CxtmkContext=map(ClassP''Gram).map(:[]).uniqueVars.consArgsTypesmkInstanceType::Name->[Name]->TypemkInstanceTypename=AppT(ConT''Gram).foldl1'AppT.(:)(ConTname).mapVarTconsArgsTypes::[Con]->[Type]consArgsTypes=concatMapconsArgswhereconsArgs::Con->[Type]consArgs(NormalC_args)=mapsndargsconsArgs(InfixCargl_argr)=[sndargl,sndargr]consArgs_=error"Error, unsupported type."uniqueVars::[Type]->[Type]uniqueVars=nub.filterisVarT.unrollAppswhereunrollApps::[Type]->[Type]unrollApps[]=[]unrollApps(a@(AppT__):ts)=unrollAppa++unrollAppstsunrollApps(other:ts)=other:unrollAppstsisVarT::Type->BoolisVarT(VarT_)=TrueisVarT_=FalsemkBody::Name->[Con]->BindingGroup->Q[Dec]mkBodytopcsbindingGroup=doletbindingGroup'|bindingGroup==[]=[(top,[])]|otherwise=bindingGroupneededInstances=concatMapsndbindingGroup'strongEdges<-mapM(calculateStrongEdgesneededInstances)bindingGroup'instances<-mapM(createInstancesneededInstancesstrongEdges)bindingGroup'letinstances'=concatinstancesnontsInstance=mkNontsInstancestrongEdgesbindingGroup'(instanceExpsinstances')topPat=mapvarP(instanceNamesinstances')env=appsE$(lamEtopPatnontsInstance):(linkRefs(lengthinstances'))[d|{-grammar :: DGrammar a;-}grammar=DGrammarZero$(sigEenv(envSignaturecs(instanceTypesinstances')))|]whereinstanceNames=map(fst.fst)instanceTypes=map(snd.fst)instanceExps=mapsnd-- Only edges that are not in the binding groupcalculateStrongEdges::[(Name,[[Type]])]->(Name,[(Name,[[Type]])])->Q(Name,[Type])calculateStrongEdgesneeded(typeName,_)=do(UserD__cs)<-getUserTypetypeNamereturn$(typeName,mkNonBGEdgestypeName(mapfstneeded)(bindingGroupEdgestypeNameneeded)cs)wherebindingGroupEdgestNamend=maybe[]concat$Prelude.lookuptNamendmkNonBGEdgesselfdonebefore=filter(not.alreadydonebeforeself).consArgsTypesalready::[Name]->[Type]->Name->Type->Boolalready___(VarT_)=Truealreadydonebeforeselfc@(ConTname)=elemcbefore||elemnamedone||name==selfalreadydonebeforeselfa@(AppT__)=elemabefore||elem(conNamea)done||(conNamea)==selfwhereconName=(\(ConTname)->name).head.unrollAppalready____=error"Error, unsupported type."-- TODO Incomplete: TupleT, ListT, etc...getEdges::Name->[(Name,[Type])]->[Type]getEdgesname=maybe[]id.Prelude.lookupname-- The non-terminal rules, wrapped in lambda expression to select the grammars from this closed groupmkNontsInstance::[(Name,[Type])]->BindingGroup->[ExpQ]->QExpmkNontsInstancestrongEdgesbindingGroupinstances=donontsTypes<-mapM(mkNontsTypestrongEdges)bindingGroupappsE$(lamE(mkNontsPatnontsTypesbindingGroup)(foldr'appE[|Empty|]instances)):(mkNontsstrongEdgesbindingGroup)wheremkNontsedges=map(mkGrammarPartedges)mkNontsPattypes=map(\(t,v)->sigPv(doreturnt)).ziptypes.nontsPatVarsnontsPatVars=map(varP.type2Nonts.fst)envSignature::[Con]->[Type]->QTypeenvSignaturecstypes=ifnull(consVarscs)thenenvSignature'elseforallT(consVarscs)(return$mkContextcs)envSignature'whereconsVars::[Con]->[TyVarBndr]consVars=map(\(VarTn)->(PlainTVn)).uniqueVars.consArgsTypesenvSignature'::QTypeenvSignature'=foldl1'appT[conT''Env,conT''DGram,tupleTypestypes,tupleTypestypes]-- Make a nested tuple of the types tupleTypes::[Type]->QTypetupleTypes=foldr'((\xxs->appT(appT(tupleT2)xs)x))(conT''()).mapreturn-- If there are args, see if we need instances (from needed)-- Create all needed instances-- Also, if there's still a var, create a consG for that-- Return a list of tuples of the name of an instance and the instance itselfcreateInstances::[(Name,[[Type]])]->[(Name,[Type])]->(Name,[(Name,[[Type]])])->Q[((Name,Type),ExpQ)]createInstancesneededstrongEdges(typeName,edges)=do(UserD_args_)<-getUserTypetypeNameletinstancesNeeded=maybe[mapVarTargs]id$Prelude.lookuptypeNameneededreturn$mkInstancesinstancesNeeded++mkArgInstancesinstancesNeeded++mkNonBGInstancestypeNamestrongEdgeswheremkConsG::Type->((Name,Type),ExpQ)mkConsGtyp=((instNametypeNametyp,typ),[|consGgrammar|])mkInstances=map(createInstance(typeName,edges)(getEdgestypeNamestrongEdges))mkArgInstances=mapmkConsG.filterisVarT.concatmkNonBGInstancestName=mapmkConsG.getEdgestNamecreateInstance::(Name,[(Name,[[Type]])])->[Type]->[Type]->((Name,Type),ExpQ)createInstance(typeName,edges)strongEdgesinst=((iName,iType),[|consD$(appsE$(varE$type2NontstypeName):(selfArgs++strongEdgeArgs++nonBGStrongEdges))|])whereiName=nameArgs(type2TopReftypeName)instiType=foldl1'AppT(ConTtypeName:inst)selfArgs=(varEiName):(map(varE.instNametypeName)inst)strongEdgeArgs=concatMaprefEdgeedgesnonBGStrongEdges=map(varE.instNametypeName)strongEdgesinstName::Name->Type->NameinstNametop(VarTn)=var2TopReftopninstName_(ConTn)=type2TopRefninstName_app@(AppT__)=app2TopRef$unrollAppappinstName__=error"Error, unsupported type."mkNontsType::[(Name,[Type])]->(Name,[(Name,[[Type]])])->QTypemkNontsTypestrongEdges(typeName,edges)=do(UserD_args_)<-getUserTypetypeNameletenvName=mkName"env"env=VarTenvNameref=ConT''RefargsType=mapVarTargstopType=foldl'AppT(ConTtypeName)argsTyperesultType=AppT(AppT(ConT''DLNontDefs)topType)envrefTo=(topType:argsType)++concatMapedgeTypeedges++getEdgestypeNamestrongEdgesrefs=map(\r->AppT(AppTrefr)env)refTonontsType=foldr'(\rrs->AppT(AppTArrowTr)rs)resultTyperefsreturn$ForallT((PlainTVenvName):(mapPlainTVargs))[]nontsTypeedgeType::(Name,[[Type]])->[Type]edgeType(con,argss)=map(foldl'AppT(ConTcon))argssmkGrammarPart::[(Name,[Type])]->(Name,[(Name,[[Type]])])->QExpmkGrammarPartstrongEdges(typeName,edges)=do(UserD_argscons)<-getUserTypetypeNameletselfArgsNames=(type2ReftypeName):(map(var2ReftypeName)args)strongEdgeNames=concatMapnameEdgeedges-- Strong edges that are not part of the binding groupnonBGStrongEdgeNames=mapgetTypeName$getEdgestypeNamestrongEdgeslamE(mapvarP(selfArgsNames++strongEdgeNames++nonBGStrongEdgeNames))(conProdsconstypeName)wheregetTypeName(ConTname)=type2RefnamegetTypeNamea@(AppT__)=app2Ref(unrollAppa)getTypeName_=error"Error, unsupported type."-- TODO Incomplete: TupleT, ListT, etc...refEdge::(Name,[[Type]])->[ExpQ]refEdge(con,argss)=map(varE.nameArgsbaseName)argsswherebaseName=type2TopRefconnameEdge::(Name,[[Type]])->[Name]nameEdge(con,argss)=map(nameArgsbaseName)argsswherebaseName=type2Refcon-- TODO: Extend this for 'AppT' and clean upnameArgs::Name->[Type]->NamenameArgsbaseName[]=baseNamenameArgsbaseName((ConTname):types)=nameArgs(mkName$nameBasebaseName++"'"++nameBasename)typesnameArgsbaseName((VarTname):types)=nameArgs(mkName$nameBasebaseName++"'"++nameBasename)typesnameArgs__=error"Error, unsupported type."-- TODO: Simplification, not finished, doesn't support AppT at the momentgetNeededInstances::(Name,[[Type]])->[(Name,[Type])]getNeededInstances(top,argss)=concatMap(\args->(top,args):map(\arg->(typeNamearg,[]))args)argsswheretypeName(ConTn)=n-- Break with a pattern match failuretypeName_=error"Error, unsupported type."linkRefs::Int->[ExpQ]linkRefsx=linkRefs'(x-1)[[|Zero|]]-- Minus one is for the top type, works alwayswherelinkRefs'0done=reversedonelinkRefs'x'l@(lst:_)=linkRefs'(x'-1)((appE[|Suc|]lst):l)linkRefs'__=error"Impossible Error!"typePrecProd=MapInt[ExpQ]conProds::[Con]->Name->QExpconProdscstop=doprods<-foldM(insertContop)Map.emptycs-- Add the parenthesis productionprods'<-insertCon'10(parensProdtop)prodsletprodList=map(\(prec,nonts)->tupE[[|DRef($(varE$type2Reftop),prec)|],appE[|DPS|](listEnonts)])(Map.toListprods')appE[|DLNontDefs|]$listEprodListparensProd::Name->QExpparensProdtop=[|dTerm"(".#.(dNont($(varE$type2Reftop),0)).#.dTerm")".#.dEndparenT|]getTypeRef::Name->Int->StrictType->QExpgetTypeReftopp(_,t)=[|dNont($(varE(refTotopt)),p)|]whererefTotop'(VarTn)=var2Reftop'nrefTo_(ConTn)=type2RefnrefTotop'app@(AppT__)=appOrType2Reftop'$unrollAppapprefTo__=error"Error, unsupported type."appOrType2Refcurapp@((ConTcon):_)|cur==con=type2Refcur-- TODO: Is this always true?|otherwise=app2RefappappOrType2Ref__=error"Error, unsupported type."-- TODO Incomplete?-- TODO: first argument doesn't have to be a con!app2Ref::[Type]->Nameapp2Ref((ConTcon):args)=nameArgs(type2Refcon)argsapp2Ref_=error"Error, unsupported type."app2TopRef::[Type]->Nameapp2TopRef((ConTcon):args)=nameArgs(type2TopRefcon)argsapp2TopRef_=error"Error, unsupported type."-- TODO: Nice for readability, but should be cleaned uptype2Ref::Name->Nametype2Ref=type2Ref'"_r_"type2Ref'::String->Name->Nametype2Ref'prefixt=mkName$prefix++nameBasetvar2Ref::Name->Name->Namevar2Ref=var2Ref'"_r_"var2Ref'::String->Name->Name->Namevar2Ref'prefixtv=mkName$prefix++nameBaset++"_"++nameBasevtype2Nonts::Name->Nametype2Nonts=type2Ref'"_nonts_"var2TopRef::Name->Name->Namevar2TopRef=var2Ref'"_t_"type2TopRef::Name->Nametype2TopRef=type2Ref'"_t_"nameStringE::Name->QExpnameStringE=stringE.nameBaseinsertCon::Name->PrecProd->Con->QPrecProdinsertContoppp(NormalCnameargs)=doinsertCon'10(foldr1appE([[|(.#.)$dTerm$(nameStringEname)|]]++(map(appE[|(.#.)|].(getTypeReftop0))args)++[[|dEnd$(consExpname(lengthargs))|]]))ppinsertContoppp(InfixCarglnameargr)=do(prec,precl,precr)<-getPrecnameletrefl=getTypeReftoppreclarglrefr=getTypeReftopprecrargrinsertCon'prec(infixProdrefl(nameBasename)refr(conEname))ppinsertCon___=undefined-- TODOinfixProd::ExpQ->String->ExpQ->ExpQ->QExpinfixProdargltermargrop=[|$argl.#.dTermterm.#.$argr.#.dEnd(\e1_e2->$(appsE[op,[|e2|],[|e1|]]))|]getPrec::Name->Q(Int,Int,Int)getPrecname=do(DataConI___(Fixityffd))<-reifynamereturn(f,(f+fLeftfd),(f+fRightfd))wherefLeftInfixL=0fLeftInfixR=1fLeft_=error"Error, unsupported fixity."fRightInfixR=0fRightInfixL=1fRight_=error"Error, unsupported fixity."insertCon'::Int->ExpQ->PrecProd->QPrecProdinsertCon'iepp=return$Map.insertWith(flip(++))i[e]ppconsExp::Name->Int->QExpconsExpnametimes=doletnames=map(\x->mkName$"arg"++showx)[1..times]lamE(mapvarPnames++[wildP])(appsE$(conEname):(mapvarE(reversenames)))