{-# LANGUAGE TemplateHaskell
, UndecidableInstances
, TypeOperators
, ScopedTypeVariables
, GADTs
, GeneralizedNewtypeDeriving
, CPP
#-}{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}------------------------------------------------------------------------------- |-- Module : Generics.RepLib.Derive-- License : TBD---- Maintainer : sweirich@cis.upenn.edu-- Stability : experimental-- Portability : non-portable---- Automatically derive representations and instance declarations-- for user defined datatypes.-- The typical use is-- @-- $(derive [''MyType1, ''MyType2])-- @-------------------------------------------------------------------------------moduleGenerics.RepLib.Derive(derive,derive_abstract)whereimportGenerics.RepLib.RimportGenerics.RepLib.R1importLanguage.Haskell.THhiding(Con)importqualifiedLanguage.Haskell.THasTH(Con)importLanguage.Haskell.TH.Syntax(Quasi(..))importData.List(foldl',nub)importqualifiedData.SetasSimportData.Maybe(catMaybes)importData.Type.EqualityimportControl.Monad(replicateM,zipWithM,liftM,liftM2,when)importControl.Monad.Writer(WriterT,MonadWriter(..),runWriterT,lift)importControl.Arrow((***),second)importControl.Applicative((<$>),Applicative)importUnsafe.Coerce-- | Given a type, produce its representation.repty::Type->Expreptyty=SigE(VarE(mkName"rep"))((ConT''R)`AppT`ty)rName::Name->NamerNamen=casenameBasenof"(,,,,,,)"->mkName("rTup7")"(,,,,,)"->mkName("rTup6")"(,,,,)"->mkName("rTup5")"(,,,)"->mkName("rTup4")"(,,)"->mkName("rTup3")"(,)"->mkName("rTup2")c->mkName("r"++c)rName1::Name->NamerName1n=casenameBasenof"(,,,,,,)"->mkName("rTup7_1")"(,,,,,)"->mkName("rTup6_1")"(,,,,)"->mkName("rTup5_1")"(,,,)"->mkName("rTup4_1")"(,,)"->mkName("rTup3_1")"(,)"->mkName("rTup2_1")c->mkName("r"++c++"1")------------------------------------------------------------------------------------ Q-like monad which also remembers a Set of Int values. We use this-- to keep track of which Res/destr definitions we end up needing-- while generating constructor representations.newtypeQNa=QN{unQN::WriterT(S.SetInt)Qa}#if MIN_VERSION_template_haskell(2,7,0)deriving(Applicative,Functor,Monad,MonadWriter(S.SetInt))#else deriving(Functor,Monad,MonadWriter(S.SetInt))#endifliftQN::Qa->QNaliftQN=QN.liftrunQN::QNa->Q(a,S.SetInt)runQN=runWriterT.unQNinstanceQuasiQNwhereqNewNames=liftQN$qNewNamesqReportbs=liftQN$qReportbsqRecover=error"qRecover not implemented for QN"qReifyn=liftQN$qReifyn#if MIN_VERSION_template_haskell(2,7,0)qReifyInstancesntys=liftQN$qReifyInstancesntys#elseqClassInstancesntys=liftQN$qClassInstancesntys#endifqLocation=liftQNqLocationqRunIOio=liftQN$qRunIOio#if MIN_VERSION_template_haskell(2,7,0)qLookupNamenss=liftQN$qLookupNamenssqAddDependentFilefp=liftQN$qAddDependentFilefp#endif-- Generate the representation for a data constructor.-- As our representation of data constructors evolves, so must this definition.-- Currently, we don't handle data constructors with record components.-- | Generate an R-type constructor representation.repcon::TypeInfo->-- information about the typeConstrInfo->-- information about the constructorQNExprepconinfoconstr|null(constrCxtconstr)=liftQN[|Just$con|]|otherwise=gadtCase(typeParamsinfo)constrconwhereargs=map(return.repty.fieldType).constrFields$constrmtup=foldr(\ttl->[|$(t):+:$(tl)|])[|MNil|]argscon=[|Con$(rembconstr)$(mtup)|]gadtCase::[TyVarBndr]->ConstrInfo->QExp->QNExpgadtCasetyVarsconstrconQ=docon<-liftQN[|Just$conQ|](m,pat)<-typeRefinementstyVarsconstrn<-liftQN[|Nothing|]return$CaseEm[Matchpat(NormalBcon)[],MatchWildP(NormalBn)[]]typeRefinements::[TyVarBndr]->ConstrInfo->QN(Exp,Pat)typeRefinementstyVarsconstr=fmap((TupE***TupP).unzip).sequence.mapgenRefinement.extractParamEqualitiestyVars$constrCxtconstrextractParamEqualities::[TyVarBndr]->Cxt->[(Name,Type)]extractParamEqualitiestyVars=filterWithextractLHSVars.filterWithextractEqwhereextractEq::Pred->Maybe(Type,Type)extractEq(EqualPty1ty2)=Just(ty1,ty2)extractEq_=NothingextractLHSVars(VarTn,t2)|any((==n).tyVarBndrName)tyVars=Just(n,t2)extractLHSVars_=Nothing-- Note, assuming here that equalities involving type parameters-- will always have the type parameter on the LHS...filterWith::(a->Maybeb)->[a]->[b]filterWithf=catMaybes.mapf-- The third result is the arity of the type constructor, hence the N-- of the required ResN/destrN declarations.genRefinement::(Name,Type)->QN(Exp,Pat)genRefinement(n,ty)=dolet(con,args)=decomposeTytywhen(not(nullargs))$tell$S.singleton(lengthargs)liftQN$caseargsof[]->doe<-[|eqT(rep::R$(varTn))$(return$reptyty)|]p<-[p|JustRefl|]return(e,p)_->doe<-[|$(varE(mkName$"destr"++show(lengthargs)))(rep::R$(varTn))(rep::R$(appUnitscon(lengthargs)))|]p<-conP(mkName$"Result"++show(lengthargs))[sigP[p|Refl|][t|$(varTn):=:$(returnty)|]]return(e,p)-- | Decompose a type into a constructor and a list of arguments.decomposeTy::Type->(Type,[Type])decomposeTy(AppTt1t2)=second(++[t2])(decomposeTyt1)decomposeTyt=(t,[])-- | Apply a type constructor to a certain number of copies of the-- unit type.appUnits::Type->Int->QTypeappUnitstyn=dou<-[t|()|]return$foldl'AppTty(replicatenu)-- the "from" function that coerces from an "a" to the argumentsrfrom::ConstrInfo->QExprfromconstr=dovars<-mapM(const(newName"x"))(constrFieldsconstr)outvar<-newName"y"letnm=(simpleName.constrName$constr)letoutpat::Patoutpat=ConPnm(mapVarPvars)outbod::Expoutbod=foldr(\vtl->(ConE(mkName(":*:")))`AppE`(VarEv)`AppE`tl)(ConE'Nil)varssuccess=Matchoutpat(NormalB((ConE'Just)`AppE`outbod))[]outcasex=ifisOnlyConstrconstrthenCaseEx[success]elseCaseEx[success,MatchWildP(NormalB(ConE'Nothing))[]]return(LamE[VarPoutvar](outcase(VarEoutvar)))-- to component of th embeddingrto::ConstrInfo->QExprtoconstr=dovars<-mapM(const(newName"x"))(constrFieldsconstr)lettopat=foldr(\vtl->InfixP(VarPv)(mkName":*:")tl)(ConP'Nil[])varstobod=foldl'(\tlv->tl`AppE`(VarEv))(ConE(simpleName.constrName$constr))varsreturn(LamE[topat]tobod)-- the embedding recordremb::ConstrInfo->QExprembconstr=[|Emb{name=$(stringName.simpleName.constrName$constr),to=$(rtoconstr),from=$(rfromconstr),labels=Nothing,fixity=Nonfix}|]repDT::Name->[Name]->QExprepDTnmparam=dostr<-stringNamenmletreps=foldr(\pf->(ConE(mkName":+:"))`AppE`repty(VarTp)`AppE`f)(ConE'MNil)param[|DT$(returnstr)$(returnreps)|]dataFlag=Abs|Conc-- Create an "R" representation for a given type constructorrepr::Flag->Name->Q[Dec]reprfn=doinfo'<-reifyncaseinfo'ofTyConId->doletdInfo=typeInfodparamNames=maptyVarBndrName(typeParamsdInfo)nm=typeNamedInfoconstrs=typeConstrsdInfobaseT<-conTnm-- the type that we are defining, applied to its parameters.letty=foldl'(\xp->x`AppT`(VarTp))baseTparamNames-- the representations of the paramters, as a list-- representations of the data constructors(rcons,ks)<-runQN$mapM(repcondInfo)constrsress<-casefofConc->deriveRessksAbs->return[]body<-casefofConc->[|Data$(repDTnmparamNames)(catMaybes$(return(ListErcons)))|]Abs->[|Abstract$(repDTnmparamNames)|]letctx=map(\p->ClassP(mkName"Rep")[VarTp])paramNamesletrTypeName::NamerTypeName=rNamenrSig::DecrSig=SigDrTypeName(ForallT(mapPlainTVparamNames)ctx((ConT(mkName"R"))`AppT`ty))rType::DecrType=ValD(VarPrTypeName)(NormalBbody)[]letinst=InstanceDctx((ConT(mkName"Rep"))`AppT`ty)[ValD(VarP(mkName"rep"))(NormalB(VarErTypeName))[]]return$ress++[rSig,rType,inst]reprs::Flag->[Name]->Q[Dec]reprsfns=concat<$>mapM(reprf)ns----------------------------------------------------------------------------------------------- Generating the R1 representation-- The difficult part of repr1 is that we need to paramerize over reps for types that-- appear as arguments of constructors, as well as the reps of parameters.-- The constructor for the R1 representation takes one argument-- corresponding to each constructor, providing contexts for the-- arguments to that constructor. Some of them are just (tuples of)-- applications of ctx to some type. However, for GADT constructors,-- the argument is a polymorphic function which takes an equality-- proof (in order to refine one or more type parameters) and then-- returns some contexts. For example, for---- data Foo a where-- Bar :: Int -> Foo Int-- Bar2 :: Foo b -> Foo [b]-- Bar3 :: Foo c -> Foo d -> Foo (c,d)---- we have---- rFoo1 ::-- forall ctx a. Rep a =>-- ctx Int ->-- (forall b. a :=: [b] -> ctx (Foo b)) ->-- (forall c d. a :=: (c,d) -> (ctx (Foo c), ctx (Foo d))) ->-- R1 ctx (Foo a)dataCtxParam=CtxParam{cpName::Name-- The argument name,cpType::Type-- The argument type,cpEqs::[(Name,Type)]-- Required equality proofs,cpTyVars::[Name]-- /All/ type variable arguments to the type-- (not just ones requiring equality proofs);-- needed when generating special Sat classes,cpPayload::Type-- What you get after supplying-- the proofs,cpPayloadElts::[Type]-- individual elements in-- the payload,cpCtxName::Name,cpSat::Maybe(Name,Name)-- names of the special Sat-like class and-- its dictionary method for this-- constructor}-- | Generate the context parameters (see above) for a given type.ctx_params::TypeInfo->-- information about the type we are definingName->-- name of the type variable "ctx"[ConstrInfo]->-- information about the type's constructorsQ[CtxParam]ctx_paramstyInfoctxNameconstrs=mapM(genCtxParamctxNametyInfo)constrs-- | Generate a context parameter for a single constructor.genCtxParam::Name->TypeInfo->ConstrInfo->QCtxParamgenCtxParamctxNametyInfoconstr=newName"c">>=\c->return(CtxParamcpTypeeqstvarspayloadpayloadEltsctxNameNothing)whereallEqs=extractParamEqualities(typeParamstyInfo)(constrCxtconstr)eqs=filter(not.S.null.tyFV.snd)allEqstvars=maptyVarBndrName.typeParams$tyInfopType|nulleqs=payload|otherwise=guardedpayloadElts=map((VarTctxName`AppT`).fieldType).constrFields$constrpayload=mkTupleTpayloadEltsguarded=ForallTvars[](foldr(AppT.AppTArrowT)payloadproofs)vars=mapPlainTV$concatMap(S.toList.tyFV.snd)eqsproofs=mapmkProofeqsmkProof(n,ty)=AppT(AppT(ConT(mkName":=:"))(VarTn))tymkTupleT::[Type]->TypemkTupleTtys=foldl'AppT(TupleT(lengthtys))tys-- | Compute the free type variables of a type.tyFV::Type->S.SetNametyFV(ForallTvs_ty)=tyFVty`S.difference`(S.fromList.maptyVarBndrName$vs)tyFV(VarTn)=S.singletonntyFV(ConT_)=S.emptytyFV(TupleT_)=S.emptytyFVArrowT=S.emptytyFVListT=S.emptytyFV(AppTty1ty2)=tyFVty1`S.union`tyFVty2tyFV(SigTty_)=tyFVtyrepcon1::TypeInfo-- information about the type->CtxParam-- corresponding context parameter->ConstrInfo-- info about the constructor->QExprepcon1infoctxParamconstr=docs<-replicateM(length.constrFields$constr)(newName"c")letconBody=caseE(applyPfsctxParam)[match(tupP.mapvarP$cs)(normalBcon)[]]args=mapvarEcsmtup=foldr(\ttl->[|$(t):+:$(tl)|])[|MNil|]argscon=[|Con$(rembconstr)$(mtup)|]case(null(constrCxtconstr))ofTrue->[|Just$conBody|]_->fst<$>(runQN$gadtCase(typeParamsinfo)constrconBody)-- | Apply a context parameter to the right number of equality proofs-- to get out the promised context.applyPfs::CtxParam->QExpapplyPfs(CtxParam{cpName=n,cpEqs=eqs})=appsE(varEn:replicate(lengtheqs)[|Refl|])genSatClass::CtxParam->Q(CtxParam,[Dec])genSatClassctxParam|null(cpEqsctxParam)=return(ctxParam,[])|otherwise=dosatNm<-newName"Sat"dictNm<-newName"dict"letctx=cpCtxNamectxParameqs=cpEqsctxParamtvs=cpTyVarsctxParamsatClass=ClassD[]satNm(PlainTVctx:mapPlainTVtvs)[][SigDdictNm(cpTypectxParam)]satInstHead=foldl'AppT(ConTsatNm)(VarTctx:maptvOrEqTypetvs)tvOrEqTypea=caselookupaeqsofJustt->tNothing->VarTasatInst=InstanceD(map(ClassP''Sat.(:[]))(cpPayloadEltsctxParam))satInstHead[ValD(VarPdictNm)(NormalB(LamE(replicate(lengtheqs)(ConP'Refl[]))(TupE(replicate(length(cpPayloadEltsctxParam))(VarE'dict)))))[]]nms<-replicateM(lengthtvs)(newName"a")err<-[|error"Impossible Sat instance!"|]letdefSatInst=InstanceD[](foldl'AppT(ConTsatNm)(mapVarT(ctx:nms)))[ValD(VarPdictNm)(NormalB(LamE(replicate(lengtheqs)(ConP'Refl[]))err))[]]return(ctxParam{cpSat=Just(satNm,dictNm)},[satClass,satInst,defSatInst])genSatClasses::[CtxParam]->Q([CtxParam],[Dec])genSatClassesps=(secondconcat.unzip)<$>mapMgenSatClassps-- XXX look at Basics.hs -- tree example. The context for recursive-- subtrees ends up getting duplicated. Need to nub out something so-- that doesn't happen.-- Generate a parameterized representation of a typerepr1::Flag->Name->Q[Dec]repr1fn=doinfo'<-reifyncaseinfo'ofTyConId->doletdInfo=typeInfodparamNames=maptyVarBndrName(typeParamsdInfo)nm=typeNamedInfoconstrs=typeConstrsdInfo-- the type that we are defining, applied to its parameters.letty=foldl'(\xp->x`AppT`(VarTp))(ConTnm)paramNamesletrTypeName=rName1nctx<-newName"ctx"ctxParams<-casefofConc->ctx_paramsdInfoctxconstrsAbs->return[]r1Ty<-[t|$(conT$''R1)$(varTctx)$(returnty)|]letctxRep=map(\p->ClassP(''Rep)[VarTp])paramNamesrSig=SigDrTypeName(ForallT(mapPlainTV(ctx:paramNames))ctxRep(foldr(AppT.AppTArrowT)r1Ty(mapcpTypectxParams)))rcons<-zipWithM(repcon1dInfo)ctxParamsconstrsbody<-casefofConc->[|Data1$(repDTnmparamNames)(catMaybes$(return(ListErcons)))|]Abs->[|Abstract1$(repDTnmparamNames)|]letrhs=LamE(map(VarP.cpName)ctxParams)bodyrDecl=ValD(VarPrTypeName)(NormalBrhs)[]-- generate a Sat-like class for each constructor requiring-- equality proofs(ctxParams',satClasses)<-genSatClassesctxParamsletmkCtxRecc=casecpSatcofNothing->map(ClassP''Sat.(:[]))(cpPayloadEltsc)Just(s,_)->[ClassPs(mapVarT(cpCtxNamec:paramNames))]ctxRec=nub$concatMapmkCtxRecctxParams'mkDictArgc=casecpSatcofJust(_,dn)->VarEdnNothing->TupE(replicate(length(cpPayloadEltsc))(VarE'dict))dicts=mapmkDictArgctxParams'inst<-instanceD(return$ctxRep++ctxRec)(conT''Rep1`appT`varTctx`appT`(returnty))[valD(varP'rep1)(normalB(appsE(varErTypeName:mapreturndicts)))[]]-- generate the Rep instances as welldecs<-reprfnreturn(decs++[rSig,rDecl]++satClasses++[inst])repr1s::Flag->[Name]->Q[Dec]repr1sfns=concat<$>mapM(repr1f)ns-- | Generate representations (both basic and parameterized) for a list of-- types.derive::[Name]->Q[Dec]derive=repr1sConc-- | Generate abstract representations for a list of types.derive_abstract::[Name]->Q[Dec]derive_abstract=repr1sAbs----------------------------------------------------------------------------------------- Helper functionsstringName::Name->QExpstringNamen=return(LitE(StringL(nameBasen)))dataTypeInfo=TypeInfo{typeName::Name,typeParams::[TyVarBndr],typeConstrs::[ConstrInfo]}dataConstrInfo=ConstrInfo{constrName::Name-- careful, this is NOT-- simplified; may need to-- call simpleName first,constrBinders::[TyVarBndr],constrCxt::Cxt,constrFields::[FieldInfo],isOnlyConstr::Bool-- is this the only-- constructor of its type?}mkConstr::Name->ConstrInfomkConstrnm=ConstrInfonm[][][]FalsedataFieldInfo=FieldInfo{fieldName::MaybeName,fieldType::Type}typeInfo::Dec->TypeInfotypeInfod=casedof(DataD_____)->TypeInfo(getNamed)(paramsAd)(consAd)(NewtypeD_____)->TypeInfo(getNamed)(paramsAd)(consAd)_->error("derive: not a data type declaration: "++showd)wheregetName(DataD_n___)=ngetName(NewtypeD_n___)=ngetNamex=error$"Impossible! "++showx++" is neither data nor newtype"paramsA(DataD__ps__)=psparamsA(NewtypeD__ps__)=psconsA(DataD___cs_)=rememberOnly$mapconAcsconsA(NewtypeD___c_)=rememberOnly$[conAc]conA(NormalCcxs)=(mkConstrc){constrFields=mapnormalFieldxs}conA(RecCcxs)=(mkConstrc){constrFields=maprecFieldxs}conA(InfixCt1ct2)=(mkConstrc){constrFields=mapnormalField[t1,t2]}conA(ForallCbdrscxcon)=letc'=conAconinc'{constrBinders=bdrs++constrBindersc',constrCxt=cx++constrCxtc'}normalFieldx=FieldInfo{fieldName=Nothing,fieldType=sndx}recField(n,_,t)=FieldInfo{fieldName=Just$simpleNamen,fieldType=t}rememberOnly::[ConstrInfo]->[ConstrInfo]rememberOnly[con]=[con{isOnlyConstr=True}]rememberOnlycons=conssimpleName::Name->NamesimpleNamenm=lets=nameBasenmincasedropWhile(/=':')sof[]->mkNames_:[]->mkNames_:t->mkNamettyVarBndrName::TyVarBndr->NametyVarBndrName(PlainTVn)=ntyVarBndrName(KindedTVn_)=n------------------------------------------------------------------ Generating ResN types with associated destructor functions----------------------------------------------------------------{- Derive declarations of the form
data Res2 c2 a where
Result2 :: (Rep d, Rep e) => a :=: (c2 d e) -> Res2 c2 a
NoResult2 :: Res2 c2 a
destr2 :: R a -> R (c2 d e) -> Res2 c2 a
destr2 (Data (DT s1 ((rd :: R d) :+: (re :: R e) :+: MNil)) _)
(Data (DT s2 _) _)
| s1 == s2 = Result2 (unsafeCoerce Refl :: a :=: (c2 d e))
| otherwise = NoResult2
destr2 _ _ = NoResult2
for taking apart applications of type constructors of arity n.
-}deriveRess::S.SetInt->Q[Dec]deriveRess=S.fold(liftM2(++).deriveResMaybe)(return[])deriveResMaybe::Int->Q[Dec]deriveResMayben=recover(deriveResn)(reify(mkName$"Res"++shown)>>return[])deriveRes::Int->Q[Dec]deriveResn|n<0=error"deriveRes should only be called with positive arguments"deriveResn=doc<-newName"c"a<-newName"a"bs<-replicateMn(newName"b")liftM(deriveResDatancabs:)(deriveResDestrncabs)deriveResData::Int->Name->Name->[Name]->DecderiveResDatancabs=DataD[](mkName$"Res"++shown)(mapPlainTV[c,a])[deriveResultConncabs,deriveNoResultConn][]deriveResultCon::Int->Name->Name->[Name]->TH.ConderiveResultConncabs=ForallC(mapPlainTVbs)(map(ClassP''Rep.(:[]).VarT)bs)(NormalC(mkName$"Result"++shown)[(NotStrict,deriveResultEqcabs)])deriveResultEq::Name-- Tyvar representing the type to be deconstructed->Name-- Constructor tyvar->[Name]-- Argument tyvars->TypederiveResultEqcabs=AppT(AppT(ConT(mkName":=:"))(VarTa))(appsT(VarTc)bs)deriveNoResultCon::Int->TH.ConderiveNoResultConn=NormalC(mkName$"NoResult"++shown)[]deriveResDestr::Int->Name->Name->[Name]->Q[Dec]deriveResDestrncabs=doletsig=deriveResDestrSigncabsdecl<-deriveResDestrDeclnca(lengthbs)return[sig,decl]deriveResDestrSig::Int->Name->Name->[Name]->DecderiveResDestrSigncabs=SigD(mkName$"destr"++shown)(ForallT(mapPlainTV$[c,a]++bs)[]((AppT(ConT''R)(VarTa))`arr`(AppT(ConT''R)(appsT(VarTc)bs))`arr`(AppT(AppT(ConT(mkName$"Res"++shown))(VarTc))(VarTa))))deriveResDestrDecl::Int->Name->Name->Int->QDecderiveResDestrDeclncabNum=do[s1,s2]<-replicateM2(newName"s")bs<-replicateMbNum(newName"b")return$FunD(mkName$"destr"++shown)[Clause[deriveResDestrLPats1bs,deriveResDestrRPats2](GuardedB[(NormalG(AppE(AppE(VarE'(==))(VarEs1))(VarEs2)),AppE(ConE(mkName$"Result"++shown))(SigE(AppE(VarE'unsafeCoerce)(ConE'Refl))(deriveResultEqcabs))),(NormalG(VarE'otherwise),ConE(mkName$"NoResult"++shown))])[],Clause[WildP,WildP](NormalB(ConE(mkName$"NoResult"++shown)))[]]-- (Data (DT s1 ((_ :: R b1') :+: (_ :: R b2') :+: MNil)) _)deriveResDestrLPat::Name->[Name]->PatderiveResDestrLPats1bs=ConP'Data[ConP'DT[VarPs1,foldr(\pl->InfixPp'(:+:)l)(ConP'MNil[])(map(SigPWildP.AppT(ConT''R).VarT)bs)],WildP]-- (Data (DT s2 _) _)deriveResDestrRPat::Name->PatderiveResDestrRPats2=ConP'Data[ConP'DT[VarPs2,WildP],WildP]infixr5`arr`arr::Type->Type->Typearrt1t2=AppT(AppTArrowTt1)t2appsT::Type->[Name]->TypeappsTt[]=tappsTt(n:ns)=appsT(AppTt(VarTn))ns