{-# LANGUAGE TemplateHaskell, QuasiQuotes, TupleSections,
RecordWildCards, DeriveDataTypeable, CPP #-}{-# OPTIONS_GHC -pgmPcpphs -optP--cpp #-}moduleData.Generic.Diff.TH.InternalwhereimportData.Generic.Diff.TH.TypesimportLanguage.Haskell.THimportqualifiedLanguage.Haskell.THasTHimportData.Generic.DiffimportControl.MonadimportData.Generics.Uniplate.DataimportData.Generic.Diff.TH.SpecializeimportData.Generic.Diff.TH.ConversionimportData.Maybe(fromMaybe)importData.WordimportData.Int-- | Default primitives and expressions for showing themdefaultPrimitives::[(Name,TH.Exp)]defaultPrimitives=map(,VarE'show)defaultNamesdefaultNames::[Name]defaultNames=[''Int,''Char,''String,''Float,''Double,''Int8,''Int16,''Int32,''Int64,''Word,''Word8,''Word16,''Word32,''Word64,''Integer]toConE::FamCon->TH.ExpQtoConE(FamCon{..})=case_famConHardnessofConcrete->conE'Concr`appE`conE_famConNameAbstract->conE'Abstr`appE`conE_famConNamefamInstance::[(Name,TH.Exp)]->Fam->QDecfamInstanceprims(Fam{..})=doletconstrs=universeBi_famTypes--utiliy functionfuncFromCons::(Name,FamCon->ClauseQ,[ClauseQ])->DecQfuncFromCons(n,f,extra)=funDn$mapfconstrs++extra-- f _ _ = NothingdefaultClause=clause[wildP,wildP](normalB[e|Nothing|])[]decs=mapfuncFromCons[('decEq,decClause,[defaultClause]),('apply,applyClause,[]),('fields,fieldClause,[defaultClause]),('string,stringClauseprims,[])]instanceType=conT''Family`appT`conT_famNameinstanceD(return[])instanceTypedecsdecClause::FamCon->ClauseQdecClause(FamCon{..})=case_famConHardnessofConcrete->clause[conP_famConName[],conP_famConName[]](normalB[e|Just(Refl,Refl)|])[]Abstract->dox<-newName"x"y<-newName"y"clause[conP_famConName[varPx],conP_famConName[varPy]](normalB[e|if$(varEx)==$(varEy)thenJust(Refl,Refl)elseNothing|])[]stringClause::[(Name,TH.Exp)]->FamCon->ClauseQstringClauseprims(FamCon{..})=case_famConHardnessofConcrete->clause[conP_famConName[]](normalB.stringE.nameBase$_famConOriginalName)[]Abstract->dop<-newName"p"letshowExp=fromMaybe(error$"Logic error."++show_famConOriginalName++" Primitive doesn't have a show TH.Expr")$lookup_famConOriginalNameprimsclause[conP_famConName[varPp]](normalB$returnshowExp`appE`varEp)[]fieldClause::FamCon->ClauseQfieldClause(FamCon{..})=case_famConHardnessofConcrete->doparameterNames<-replicateM(length_famConTypes)(newName"x")letparameterListP=conP_famConOriginalName$mapvarPparameterNamesbody=normalB.appE(conE'Just)$foldr(appE.appE(conE'CCons).varE)(conE'CNil)parameterNamesclause[conP_famConName[],parameterListP]body[]Abstract->clause[conP_famConName[wildP],wildP](normalB[e|JustCNil|])[]applyClause::FamCon->ClauseQapplyClause(FamCon{..})=case_famConHardnessofConcrete->doparameterNames<-replicateM(length_famConTypes)(newName"x")letparameterListP=foldl(\on->conP'CCons[varPn,o])(conP'CNil[])parameterNamesbody=normalB.foldl(\xy->appEx$varEy)(conE_famConOriginalName)$reverseparameterNamesclause[conP_famConName[],parameterListP]body[]Abstract->donx<-newName"x"clause[conP_famConName[varPnx],conP'CNil[]](normalB$varEnx)[]familyTypeInstances::Fam->Q[Dec]familyTypeInstances(Fam{..})=mapM(typInstance_famName)_famTypestypInstance::Name->FamType->QDectypInstancefamilyName(FamType{..})=do--TODO make a helper function to make it clearer what this is doingletinstanceType=foldl1appT[conT''Data.Generic.Diff.Type,conTfamilyName,return_famTypeType]dec=funD'constructors[mainClause]mainClause=clause[](normalB.listE.maptoConE$_famTypeConstructors)[]instanceD(return[])instanceType[dec]mkAllInstances::[(Name,TH.Exp)]->Fam->Q[Dec]mkAllInstancesprimsx=liftM2(:)(famInstanceprimsx)(familyTypeInstancesx)#if __GLASGOW_HASKELL__ < 706forallC::[TyVarBndr]->CxtQ->ConQ->ConQforallCnsctxtcon=liftM2(ForallCns)ctxtcon#endifmkGADTConstructor::Name->Name->TH.Type->FamCon->ConQmkGADTConstructorabtyp(FamCon{..})=case_famConHardnessofConcrete->forallC[](sequence[equalP(varTa)(returntyp),equalP(varTb)(foldr(appT.appT(conT''Cons).return)(conT''Nil)_famConTypes)])(normalC_famConName[])Abstract->forallC[](sequence[equalP(varTa)(returntyp),equalP(varTb)(conT''Nil)])(normalC_famConName[return(NotStrict,ConT_famConOriginalName)])mkGADT::Fam->QDecmkGADT(Fam{..})=doa<-newName"a"b<-newName"b"letconstrs=concatMap(\(FamType{..})->map(mkGADTConstructorab_famTypeType)_famTypeConstructors)_famTypesdataD(return[])_famName[PlainTVa,PlainTVb]constrs[]-- | The type of function used for naming the GADTs constructors---- Arg0 : The family suffix---- Arg1 : The name of the constructor ---- Arg2 : The specialized type the constructor is fromtypeConstructorRenamer=(String->Name->TH.Type->QName)-- | Customizable creation.---- Arg0 : The suffix added to the Family ---- Arg1 : Function used for naming constructors of the GADT after specialization---- Arg2 : A list of primitives and an expression for showing them---- Arg3 : The root typemakeGDiffWith::String->ConstructorRenamer->[(Name,TH.Exp)]->Name->Q[Dec]makeGDiffWithfamilyPrefixconstructorRenamerprimitivesname=doletfamilyName=mkName$nameBasename++familyPrefixprefix=nameBasename--check if it is a polymorphic typedec<-reifynamewhen(not$null[x|VarTx<-universeBidec])$error"type must be monomorphic"fam<-toFam(mapfstprimitives)(constructorRenamerprefix)familyName=<<specializenameinstances<-mkAllInstancesprimitivesfamgadt<-mkGADTfamreturn$gadt:instances-- | Default constructor renamer. Using the family suffix, the -- name of the constructor and the specialized type of constructordefaultConstructorRenamer::String->Name->TH.Type->QNamedefaultConstructorRenamerprefixntyp=return.mkName$filter(\x->x/='['&&x/=']')$prefix++typToStringtyp++prettifyNamen++"C"-- | Default suffix for the family "Family" defaultFamSuffix::StringdefaultFamSuffix="Family"-- | Create the GADT and instances for GDiff with the defaults makeGDiff::Name->Q[Dec]makeGDiff=makeGDiffWithdefaultFamSuffixdefaultConstructorRenamerdefaultPrimitives