-- | Rewriting of anonymous binders to named binders.moduleDDC.Core.Transform.Namify(Namify(..),Namifier(..),makeNamifier,namifyUnique)whereimportDDC.Core.ModuleimportDDC.Core.ExpimportDDC.Type.CollectimportDDC.Type.CompoundsimportControl.MonadimportDDC.Type.Env(Env,KindEnv,TypeEnv)importqualifiedDDC.Type.SumasSumimportqualifiedDDC.Type.EnvasEnvimportControl.Monad.State.Strict-- | Holds a function to rename binders, -- and the state of the renamer as we decend into the tree.dataNamifiersn=Namifier{-- | Create a new name for this bind that is not in the given-- environment.namifierNew::Envn->Bindn->Statesn-- | Holds the current environment during namification.,namifierEnv::Envn-- | Stack of debruijn binders that have been rewritten during-- namification.,namifierStack::[Bindn]}-- | Construct a new namifier.makeNamifier::(Envn->Bindn->Statesn)-- ^ Function to rename binders.-- The name chosen cannot be a member of the given--- environment.->Envn-- ^ Starting environment of names we cannot use.->NamifiersnmakeNamifiernewenv=Namifiernewenv[]-- | Namify a thing, -- not reusing names already in the program.namifyUnique::(Ordn,Namifyc,BindStructc)=>(KindEnvn->Namifiersn)-- ^ Make a namifier for level-1 names.->(TypeEnvn->Namifiersn)-- ^ Make a namifier for level-0 names.->cn->States(cn)namifyUniquemkNamKmkNamTxx=let(tbinds,xbinds)=collectBindsxxnamK=mkNamK(Env.fromListtbinds)namT=mkNamT(Env.fromListxbinds)innamifynamKnamTxx-- Namify ---------------------------------------------------------------------classNamify(c::*->*)where-- | Rewrite anonymous binders to named binders in a thing.namify::Ordn=>Namifiersn-- ^ Namifier for type names (level-1)->Namifiersn-- ^ Namifier for exp names (level-0)->cn-- ^ Rewrite binders in this thing.->States(cn)instanceNamifyTypewherenamifytnamxnamtt=letdown=namifytnamxnamincasettofTVaru->liftMTVar(rewriteTtnamu)TCon{}->returnttTForallbt->do(tnam',b')<-pushTtnambt'<-namifytnam'xnamtreturn$TForallb't'TAppt1t2->liftM2TApp(downt1)(downt2)TSumts->dots'<-mapMdown$Sum.toListtsreturn$TSum$Sum.fromList(Sum.kindOfSumts)ts'instanceNamify(Modulea)wherenamifytnamxnammm=dobody'<-namifytnamxnam$moduleBodymmreturn$mm{moduleBody=body'}instanceNamify(Witnessa)wherenamifytnamxnamww=letdown=namifytnamxnamincasewwofWVarau->liftM(WVara)(rewriteXtnamxnamu)WCon{}->returnwwWAppaw1w2->liftM2(WAppa)(downw1)(downw2)WJoinaw1w2->liftM2(WJoina)(downw1)(downw2)WTypeat->liftM(WTypea)(downt)instanceNamify(Expa)wherenamifytnamxnamxx={-# SCC namify #-}letdown=namifytnamxnamincasexxofXVarau->liftM2XVar(returna)(rewriteXtnamxnamu)XCon{}->returnxxXLAMabx->do(tnam',b')<-pushTtnambx'<-namifytnam'xnamxreturn$XLAMab'x'XLamabx->do(xnam',b')<-pushXtnamxnambx'<-namifytnamxnam'xreturn$XLamab'x'XAppax1x2->liftM3XApp(returna)(downx1)(downx2)XLeta(LLetbx1)x2->dox1'<-namifytnamxnamx1(xnam',b')<-pushXtnamxnambx2'<-namifytnamxnam'x2return$XLeta(LLetb'x1')x2'XLeta(LRecbxs)x2->dolet(bs,xs)=unzipbxs(xnam',bs')<-pushXstnamxnambsxs'<-mapM(namifytnamxnam')xsx2'<-namifytnamxnam'x2return$XLeta(LRec(zipbs'xs'))x2'XLeta(LPrivatebmtbs)x2->do(tnam',b')<-pushTstnamb(xnam',bs')<-pushXstnam'xnambsx2'<-namifytnam'xnam'x2return$XLeta(LPrivateb'mtbs')x2'XLeta(LWithRegionu)x2->dou'<-rewriteXtnamxnamux2'<-downx2return$XLeta(LWithRegionu')x2'XCaseax1alts->liftM2(XCasea)(downx1)(mapMdownalts)XCastacx->liftM2(XCasta)(downc)(downx)XTypeat->liftM(XTypea)(downt)XWitnessaw->liftM(XWitnessa)(downw)instanceNamify(Alta)wherenamifytnamxnam(AAltPDefaultx)=liftM(AAltPDefault)(namifytnamxnamx)namifytnamxnam(AAlt(PDataubs)x)=do(xnam',bs')<-pushXstnamxnambsx'<-namifytnamxnam'xreturn$AAlt(PDataubs')x'instanceNamify(Casta)wherenamifytnamxnamcc=letdown=namifytnamxnamincaseccofCastWeakenEffecteff->liftMCastWeakenEffect(downeff)CastWeakenClosurexs->doxs'<-mapMdownxsreturn$CastWeakenClosurexs'CastPurifyw->liftMCastPurify(downw)CastForgetw->liftMCastForget(downw)CastBox->returnCastBoxCastRun->returnCastRun-- | Rewrite level-1 anonymous binders.rewriteT::Namifiersn->Boundn->States(Boundn)rewriteTtnamu=caseuofUIxi->caselookupi(zip[0..](namifierStacktnam))ofJust(BNamen_)->return$UNamen_->returnu_->returnu-- | Rewrite level-0 anonymous binders.rewriteX::Ordn=>Namifiersn->Namifiersn->Boundn->States(Boundn)rewriteX_tnamxnamu=caseuofUIxi->caselookupi(zip[0..](namifierStackxnam))ofJust(BNamen_)->doreturn$UNamen_->returnu_->returnu-- Push ------------------------------------------------------------------------- Chosing new names for anonymous binders and pushing them on the stack.-- | Push a level-0 binder on the stack.-- When we do this we also rewrite any indices in its type annotation.pushX::Ordn=>Namifiersn->Namifiersn->Bindn->States(Namifiersn,Bindn)pushXtnamxnamb=dot'<-namifytnamxnam(typeOfBindb)letb'=replaceTypeOfBindt'bpushxnamb'-- | Push some level-0 binders on the stack.-- When we do this we also rewrite their type annotations.pushXs::Ordn=>Namifiersn->Namifiersn->[Bindn]->States(Namifiersn,[Bindn])pushXs_tnamxnam[]=return(xnam,[])pushXstnamxnam(b:bs)=do(xnam1,b')<-pushXtnamxnamb(xnam2,bs')<-pushXstnamxnam1bsreturn(xnam2,b':bs')-- | Push a level-1 binder on the stack.pushT::Ordn=>Namifiersn->Bindn->States(Namifiersn,Bindn)pushT=pushpushTs::Ordn=>Namifiersn->[Bindn]->States(Namifiersn,[Bindn])pushTstnam[]=return(tnam,[])pushTstnam(b:bs)=do(tnam1,b')<-pushTtnamb(tnam2,bs')<-pushTstnam1bsreturn(tnam2,b':bs')-- | Rewrite an anonymous binder and push it on the stack.push::Ordn=>Namifiersn->Bindn->States(Namifiersn,Bindn)pushnamb=casebofBAnont->don<-namifierNewnam(namifierEnvnam)bletb'=BNamentreturn(nam{namifierStack=b':namifierStacknam,namifierEnv=Env.extendb(namifierEnvnam)},b')_->return(nam{namifierEnv=Env.extendb(namifierEnvnam)},b)