{-# LANGUAGE CPP, PatternGuards #-}moduleAgda.TypeChecking.Monad.SignaturewhereimportControl.Arrow((***))importControl.Monad.StateimportControl.Monad.ReaderimportData.Set(Set)importqualifiedData.SetasSetimportData.Map(Map)importqualifiedData.MapasMapimportData.ListimportData.FunctionimportqualifiedAgda.Utils.IO.LocaleasLocIOimportAgda.Syntax.Abstract.NameimportAgda.Syntax.CommonimportAgda.Syntax.InternalimportAgda.Syntax.PositionimportqualifiedAgda.Compiler.JS.ParserasJSimportAgda.TypeChecking.Monad.BaseimportAgda.TypeChecking.Monad.ContextimportAgda.TypeChecking.Monad.OptionsimportAgda.TypeChecking.Monad.EnvimportAgda.TypeChecking.Monad.MutualimportAgda.TypeChecking.Monad.OpenimportAgda.TypeChecking.Free(isBinderUsed)importAgda.TypeChecking.Substitute-- import Agda.TypeChecking.Pretty -- leads to cyclicityimport{-# SOURCE #-}Agda.TypeChecking.CompiledClause.Compileimport{-# SOURCE #-}Agda.TypeChecking.PolarityimportAgda.Utils.MonadimportAgda.Utils.MapasMapimportAgda.Utils.SizeimportAgda.Utils.PermutationimportAgda.Utils.Pretty#include "../../undefined.h"importAgda.Utils.ImpossiblemodifySignature::(Signature->Signature)->TCM()modifySignaturef=modify$\s->s{stSignature=f$stSignatures}modifyImportedSignature::(Signature->Signature)->TCM()modifyImportedSignaturef=modify$\s->s{stImports=f$stImportss}getSignature::TCMSignaturegetSignature=getsstSignaturegetImportedSignature::TCMSignaturegetImportedSignature=getsstImportssetSignature::Signature->TCM()setSignaturesig=modifySignature$constsigsetImportedSignature::Signature->TCM()setImportedSignaturesig=modify$\s->s{stImports=sig}withSignature::Signature->TCMa->TCMawithSignaturesigm=dosig0<-getSignaturesetSignaturesigr<-msetSignaturesig0returnr-- | Add a constant to the signature. Lifts the definition to top level.addConstant::QName->Definition->TCM()addConstantqd=doreportSLn"tc.signature"20$"adding constant "++showq++" to signature"tel<-getContextTelescopelettel'=killRange$casetheDefdofConstructor{}->hideTeltel_->telletd'=abstracttel'$d{defName=q}reportSLn"tc.signature"30$"lambda-lifted definition = "++showd'modifySignature$\sig->sig{sigDefinitions=Map.insertWith(+++)qd'$sigDefinitionssig}i<-currentMutualBlocksetMutualBlockiqwherenew+++old=new{defDisplay=defDisplaynew++defDisplayold}hideTelEmptyTel=EmptyTelhideTel(ExtendTel(Arg_rt)tel)=ExtendTel(ArgHiddenrt)$hideTel<$>tel-- | Turn a definition into a projection if it looks like a projection.makeProjection::QName->TCM()makeProjectionx=inContext[]$doreportSLn"tc.proj.like"30$"Considering "++showx++" for projection likeness"defn<-getConstInfoxcasetheDefdefnof-- Constructor-headed functions can't be projection-like (at the moment). The reason-- for this is that invoking constructor-headedness will circumvent the inference of-- the dropped arguments.-- Nor can abstract definitions be projection-like since they won't reduce-- outside the abstract block.def@Function{funProjection=Nothing,funClauses=cls,funInv=NotInjective,funAbstr=ConcreteDef}->dops0<-filterMvalidProj(candidateArgs[](unEl$defTypedefn))reportSLn"tc.proj.like"30$ifnullps0then" no candidates found"else" candidates: "++showps0ps<-return$filter(checkOccurscls.snd)ps0when(not(nullps0)&&nullps)$reportSLn"tc.proj.like"50$" occurs check failed\n clauses = "++showclscasereversepsof[]->return()(d,n):_->doreportSLn"tc.proj.like"10$show(defNamedefn)++" is projection like in argument "++shown++" for type "++showdletcls'=map(rewriteClausen)clscc<-compileClausesTruecls'reportSLn"tc.proj.like"20$" rewrote clauses to\n "++showccletmapInvfNotInjective=NotInjectivemapInvf(Inverseinv)=Inverse(finv)newDef=def{funProjection=Just(d,n+1),funClauses=cls',funCompiled=cc,funInv=mapInv(Map.map$rewriteClausen)$funInvdef,funArgOccurrences=dropn$funArgOccurrencesdef,funPolarity=dropn$funPolaritydef}addConstantx$defn{theDef=newDef,defDisplay=[]}_->return()wherevalidProj(_,0)=returnFalsevalidProj(d,_)=dodefn<-theDef<$>getConstInfodreturn$casedefnofDatatype{}->TrueRecord{}->TrueAxiom{}->True_->FalserewriteClausencl@Clause{clausePerm=Permmp}=cl{clausePerm=Perm(m-fromIntegraln)$map(subtract$fromIntegraln)$dropnp,clauseTel=telFromList$dropn$telToList$clauseTelcl,clausePats=dropn$clausePatscl,clauseBody=dropBn$clauseBodycl}wheredropB0b=bdropB_NoBody=NoBodydropBn(Bindb)=dropB(n-1)(absBodyb)dropBnBody{}=__IMPOSSIBLE__checkOccursclsn=all(nonOccurn)clsnonOccurnClause{clausePerm=Perm_p,clausePats=ps,clauseBody=b}=and[takenp==[0..fromIntegraln-1],onlyMatchnps-- projection-like functions are only allowed to match on the eliminatee-- otherwise we may end up projecting from constructor applications, in-- which case we can't reconstruct the dropped parameters,checkBodynb]onlyMatchnps=all(noMatch.unArg)$ps0++drop1ps1where(ps0,ps1)=splitAtnpsnoMatchConP{}=FalsenoMatchLitP{}=FalsenoMatchVarP{}=TruenoMatchDotP{}=TruecheckBody0_=TruecheckBody_NoBody=TruecheckBodyn(Bindb)=not(isBinderUsedb)&&checkBody(n-1)(unAbsb)checkBody_Body{}=__IMPOSSIBLE__candidateArgsvs(Pi(Argrh(El_(Defdus)))b)|vs==mapunArgus=(d,lengthvs):candidateRecvsbcandidateArgsvs(Pi_b)=candidateRecvsbcandidateArgs__=[]candidateRecvsNoAbs{}=[]candidateRecvsb=candidateArgs(Var(sizevs)[]:vs)(unEl$absBodyb)addHaskellCode::QName->HaskellType->HaskellCode->TCM()addHaskellCodeqhsTyhsDef=-- TODO: sanity checkingmodifySignature$\sig->sig{sigDefinitions=Map.adjustaddHsq$sigDefinitionssig}whereaddHsdef=def{defCompiledRep=(defCompiledRepdef){compiledHaskell=Just$HsDefnhsTyhsDef}}addHaskellType::QName->HaskellType->TCM()addHaskellTypeqhsTy=-- TODO: sanity checkingmodifySignature$\sig->sig{sigDefinitions=Map.adjustaddHsq$sigDefinitionssig}whereaddHsdef=def{defCompiledRep=(defCompiledRepdef){compiledHaskell=Just$HsTypehsTy}}addEpicCode::QName->EpicCode->TCM()addEpicCodeqepDef=-- TODO: sanity checkingmodifySignature$\sig->sig{sigDefinitions=Map.adjustaddEpq$sigDefinitionssig}where--addEp def@Defn{theDef = con@Constructor{}} =--def{theDef = con{conHsCode = Just (hsTy, hsDef)}}addEpdef=def{defCompiledRep=(defCompiledRepdef){compiledEpic=JustepDef}}addJSCode::QName->String->TCM()addJSCodeqjsDef=caseJS.parsejsDefofLefte->modifySignature$\sig->sig{sigDefinitions=Map.adjust(addJS(Juste))q$sigDefinitionssig}Rights->typeError(CompilationError("Failed to parse ECMAScript (..."++s++") for "++showq))whereaddJSedef=def{defCompiledRep=(defCompiledRepdef){compiledJS=e}}markStatic::QName->TCM()markStaticq=modifySignature$\sig->sig{sigDefinitions=Map.adjustmarkq$sigDefinitionssig}wheremarkdef@Defn{theDef=fun@Function{}}=def{theDef=fun{funStatic=True}}markdef=defunionSignatures::[Signature]->SignatureunionSignaturesss=foldrunionSignatureemptySignaturesswhereunionSignature(Sigab)(Sigcd)=Sig(Map.unionac)(Map.unionbd)-- | Add a section to the signature.addSection::ModuleName->Nat->TCM()addSectionmfv=dotel<-getContextTelescopeletsec=SectiontelfvmodifySignature$\sig->sig{sigSections=Map.insertmsec$sigSectionssig}-- | Lookup a section. If it doesn't exist that just means that the module-- wasn't parameterised.lookupSection::ModuleName->TCMTelescopelookupSectionm=dosig<-sigSections<$>getSignatureisig<-sigSections<$>getImportedSignaturereturn$maybeEmptyTelsecTelescope$Map.lookupmsig`mplus`Map.lookupmisig-- Add display forms to all names @xn@ such that @x = x1 es1@, ... @xn-1 = xn esn@.addDisplayForms::QName->TCM()addDisplayFormsx=doargs<-getContextArgsaddargsxx[]whereaddargstopxps=dodef<-getConstInfoxletcs=defClausesdefn=casetheDefdefofFunction{funProjection=Just(_,n)}->n_->0casecsof[Clause{clauseBody=b}]|Just(m,Defyvs)<-stripb->doletps'=raise1(mapunArgvs)++psdf=Display0ps'$DTerm$Deftop(drop(n-1)args)reportSLn"tc.display.section"20$"adding display form "++showy++" --> "++showtop++"\n "++showdfaddDisplayFormydfaddargstopyps'_->doletreason=casecsof[]->"no clauses"_:_:_->"many clauses"[Clause{clauseBody=b}]->casestripbofNothing->"bad body"Just(m,Defyvs)|m<lengthargs->"too few args"|m>lengthargs->"too many args"|otherwise->"args="++showargs++" vs="++showvsJust(m,v)->"not a def body"reportSLn"tc.display.section"30$"no display form from"++showx++" because "++reasonreturn()strip(Bodyv)=return(0,v)stripNoBody=Nothingstrip(Bindb)=do(n,v)<-strip$absBodybreturn(n+1,v)applySection::ModuleName->Telescope->ModuleName->Args->MapQNameQName->MapModuleNameModuleName->TCM()applySectionnewpteloldtsrdrm=dosig<-getSignatureisig<-getImportedSignatureletss=getOldpartOfOldMsigSections[sig,isig]ds=getOldpartOfOldDsigDefinitions[sig,isig]reportSLn"tc.mod.apply"10$render$vcat[text"applySection",text"new ="<+>text(shownew),text"ptel ="<+>text(showptel),text"old ="<+>text(showold),text"ts ="<+>text(showts)]reportSLn"tc.mod.apply"80$"sections: "++showss++"\n"++"definitions: "++showdsreportSLn"tc.mod.apply"80$render$vcat[text"arguments: "<+>text(showts)]mapM_(copyDefts)dsmapM_(copySects)ssmapM_computePolarity(Map.elemsrd)wheregetOldpartOfOldfromSigsigs=Map.toList$Map.filterKeyspartOfOld$Map.unions$mapfromSigsigspartOfOldMx=x`isSubModuleOf`oldpartOfOldDx=x`isInModule`oldcopyNamex=maybexid$Map.lookupxrdcopyDef::Args->(QName,Definition)->TCM()copyDefts(x,d)=caseMap.lookupxrdofNothing->return()-- if it's not in the renaming it was private and-- we won't need itJusty->doaddConstanty=<<ndymakeProjectiony-- Set display form for the old name if it's not a constructor.unless(isCon||sizeptel>0)$doaddDisplayFormsywheret=defTyped`apply`ts-- the name is set by the addConstant functionndy=Defn(defRelevanced)yt[](-1)noCompiledRep<$>def-- TODO: mutual block?oldDef=theDefdisCon=caseoldDefofConstructor{}->True_->FalsegetOccd=casedofFunction{funArgOccurrences=os}->osDatatype{dataArgOccurrences=os}->osRecord{recArgOccurrences=os}->os_->[]oldOcc=getOccoldDefdef=caseoldDefofConstructor{conPars=np,conData=d}->return$oldDef{conPars=np-sizets,conData=copyNamed}Datatype{dataPars=np,dataCons=cs}->return$oldDef{dataPars=np-sizets,dataClause=Justcl,dataCons=mapcopyNamecs,dataArgOccurrences=drop(lengthts)oldOcc}Record{recPars=np,recConType=t,recTel=tel}->return$oldDef{recPars=np-sizets,recClause=Justcl,recConType=applytts,recTel=applytelts,recArgOccurrences=drop(lengthts)oldOcc}_->docc<-compileClausesTrue[cl]letnewDef=Function{funClauses=[cl],funCompiled=cc,funDelayed=NotDelayed,funInv=NotInjective,funPolarity=[],funArgOccurrences=drop(lengthts')oldOcc,funAbstr=ConcreteDef,funProjection=proj,funStatic=False}reportSLn"tc.mod.apply"80$"new def for "++showx++"\n "++shownewDefreturnnewDefwhereproj=caseoldDefofFunction{funProjection=Just(r,n)}|sizets<n->Just(r,n-sizets)_->Nothingts'|nullts=[]|otherwise=caseoldDefofFunction{funProjection=Just(_,n)}|n==0->__IMPOSSIBLE__|otherwise->drop(n-1)ts_->tscl=Clause{clauseRange=getRange$defClausesd,clauseTel=EmptyTel,clausePerm=idP0,clausePats=[],clauseBody=Body$Defxts'}copySec::Args->(ModuleName,Section)->TCM()copySects(x,sec)=caseMap.lookupxrmofNothing->return()-- if it's not in the renaming it was private and-- we won't need itJusty->addCtxTel(applytelts)$addSectiony0wheretel=secTelescopesecaddDisplayForm::QName->DisplayForm->TCM()addDisplayFormxdf=dod<-makeOpendfmodifyImportedSignature(addd)modifySignature(addd)whereadddfsig=sig{sigDefinitions=Map.adjustaddDfxdefs}whereaddDfdef=def{defDisplay=df:defDisplaydef}defs=sigDefinitionssigcanonicalName::QName->TCMQNamecanonicalNamex=dodef<-theDef<$>getConstInfoxcasedefofConstructor{conSrcCon=c}->returncRecord{recClause=Just(Clause{clauseBody=body})}->canonicalName$extractbodyDatatype{dataClause=Just(Clause{clauseBody=body})}->canonicalName$extractbody_->returnxwhereextractNoBody=__IMPOSSIBLE__extract(Body(Defx_))=xextract(Body_)=__IMPOSSIBLE__extract(Bindb)=extract(unAbsb)-- | Can be called on either a (co)datatype, a record type or a-- (co)constructor.whatInduction::QName->TCMInductionwhatInductionc=dodef<-theDef<$>getConstInfoccasedefofDatatype{dataInduction=i}->returniRecord{}->returnInductiveConstructor{conInd=i}->returni_->__IMPOSSIBLE__-- | Does the given constructor come from a single-constructor type?---- Precondition: The name has to refer to a constructor.singleConstructorType::QName->TCMBoolsingleConstructorTypeq=dod<-theDef<$>getConstInfoqcasedofRecord{}->returnTrueConstructor{conData=d}->dodi<-theDef<$>getConstInfodreturn$casediofRecord{}->TrueDatatype{dataCons=cs}->lengthcs==1_->__IMPOSSIBLE___->__IMPOSSIBLE__-- | Lookup the definition of a name. The result is a closed thing, all free-- variables have been abstracted over.{-# SPECIALIZE getConstInfo :: QName -> TCM Definition #-}getConstInfo::MonadTCMtcm=>QName->tcmDefinitiongetConstInfoq=liftTCM$join$pureTCM$\stenv->letdefs=sigDefinitions$stSignaturestidefs=sigDefinitions$stImportsstsmash=(++)`on`maybe[](:[])incasesmash(Map.lookupqdefs)(Map.lookupqidefs)of[]->fail$"Unbound name: "++showq++" "++showQNameIdq[d]->mkAbsenvdds->fail$"Ambiguous name: "++showqwheremkAbsenvd|treatAbstractly'q'env=casemakeAbstractdofJustd->returndNothing->typeError$NotInScope[qnameToConcreteq]-- the above can happen since the scope checker is a bit sloppy with 'abstract'|otherwise=returndwhereq'=casetheDefdof-- Hack to make abstract constructors work properly. The constructors-- live in a module with the same name as the datatype, but for 'abstract'-- purposes they're considered to be in the same module as the datatype.Constructor{}->dropLastModuleq_->qdropLastModuleq@QName{qnameModule=m}=q{qnameModule=mnameFromList$init'$mnameToListm}init'[]={-'-}__IMPOSSIBLE__init'xs=initxs-- | Look up the polarity of a definition.getPolarity::QName->TCM[Polarity]getPolarityq=dodefn<-theDef<$>getConstInfoqcasedefnofFunction{funPolarity=p}->returnpDatatype{dataPolarity=p}->returnpRecord{recPolarity=p}->returnp_->return[]getPolarity'::Comparison->QName->TCM[Polarity]getPolarity'CmpEq_=return[]getPolarity'CmpLeqq=getPolarityq-- | Set the polarity of a definition.setPolarity::QName->[Polarity]->TCM()setPolarityqpol=domodifySignaturesetPwheresetPsig=sig{sigDefinitions=Map.adjustsetPxqdefs}wheresetPxdef=def{theDef=setPd$theDefdef}setPdd=casedofFunction{}->d{funPolarity=pol}Datatype{}->d{dataPolarity=pol}Record{}->d{recPolarity=pol}_->ddefs=sigDefinitionssiggetArgOccurrence::QName->Nat->TCMOccurrencegetArgOccurrencedi=dodef<-theDef<$>getConstInfodreturn$casedefofFunction{funArgOccurrences=os}->lookiosDatatype{dataArgOccurrences=os}->lookiosRecord{recArgOccurrences=os}->lookiosConstructor{}->Positive_->Negativewherelookios=(os++repeatNegative)!!fromIntegralisetArgOccurrences::QName->[Occurrence]->TCM()setArgOccurrencesdos=modifySignaturesetOwheresetOsig=sig{sigDefinitions=Map.adjustsetOxddefs}wheresetOxdef=def{theDef=setOd$theDefdef}setOdd=casedofFunction{}->d{funArgOccurrences=os}Datatype{}->d{dataArgOccurrences=os}Record{}->d{recArgOccurrences=os}_->ddefs=sigDefinitionssig-- | Look up the number of free variables of a section. This is equal to the-- number of parameters if we're currently inside the section and 0 otherwise.getSecFreeVars::ModuleName->TCMNatgetSecFreeVarsm=dosig<-sigSections<$>getSignatureisig<-sigSections<$>getImportedSignaturetop<-currentModulecasetop`isSubModuleOf`m||top==mofTrue->return$maybe0secFreeVars$Map.lookupm(Map.unionsigisig)False->return0-- | Compute the number of free variables of a module. This is the sum of-- the free variables of its sections.getModuleFreeVars::ModuleName->TCMNatgetModuleFreeVarsm=sum<$>((:)<$>getAnonymousVariablesm<*>mapMgetSecFreeVarsms)wherems=mapmnameFromList.inits.mnameToList$m-- | Compute the number of free variables of a defined name. This is the sum of-- the free variables of the sections it's contained in.getDefFreeVars::QName->TCMNatgetDefFreeVarsq=getModuleFreeVars(qnameModuleq)-- | Compute the context variables to apply a definition to.freeVarsToApply::QName->TCMArgsfreeVarsToApplyx=genericTake<$>getDefFreeVarsx<*>getContextArgs-- | Instantiate a closed definition with the correct part of the current-- context.instantiateDef::Definition->TCMDefinitioninstantiateDefd=dovs<-freeVarsToApply$defNamedverboseS"tc.sig.inst"30$doctx<-getContextm<-currentModuleliftIO$LocIO.putStrLn$"instDef in "++showm++": "++show(defNamed)++" "++unwords(mapshow.take(sizevs).reverse.map(fst.unArg)$ctx)return$d`apply`vs-- | Give the abstract view of a definition.makeAbstract::Definition->MaybeDefinitionmakeAbstractd=dodef<-makeAbs$theDefdreturnd{theDef=def}wheremakeAbsDatatype{dataAbstr=AbstractDef}=JustAxiommakeAbsFunction{funAbstr=AbstractDef}=JustAxiommakeAbsConstructor{conAbstr=AbstractDef}=NothingmakeAbsd=Justd-- | Enter abstract mode. Abstract definition in the current module are transparent.inAbstractMode::TCMa->TCMainAbstractMode=local$\e->e{envAbstractMode=AbstractMode}-- | Not in abstract mode. All abstract definitions are opaque.inConcreteMode::TCMa->TCMainConcreteMode=local$\e->e{envAbstractMode=ConcreteMode}-- | Ignore abstract mode. All abstract definitions are transparent.ignoreAbstractMode::TCMa->TCMaignoreAbstractMode=local$\e->e{envAbstractMode=IgnoreAbstractMode}-- | Check whether a name might have to be treated abstractly (either if we're-- 'inAbstractMode' or it's not a local name). Returns true for things not-- declared abstract as well, but for those 'makeAbstract' will have no effect.treatAbstractly::QName->TCMBooltreatAbstractlyq=treatAbstractly'q<$>asktreatAbstractly'::QName->TCEnv->BooltreatAbstractly'qenv=caseenvAbstractModeenvofConcreteMode->TrueIgnoreAbstractMode->FalseAbstractMode->not$current==m||current`isSubModuleOf`mwherecurrent=envCurrentModuleenvm=qnameModuleq-- | get type of a constanttypeOfConst::QName->TCMTypetypeOfConstq=defType<$>(instantiateDef=<<getConstInfoq)-- | get relevance of a constantrelOfConst::QName->TCMRelevancerelOfConstq=defRelevance<$>getConstInfoq-- | The name must be a datatype.sortOfConst::QName->TCMSortsortOfConstq=dod<-theDef<$>getConstInfoqcasedofDatatype{dataSort=s}->returns_->fail$"Expected "++showq++" to be a datatype."-- | Is it the name of a record projection?isProjection::QName->TCM(Maybe(QName,Int))isProjectionqn=dodef<-theDef<$>getConstInfoqncasedefofFunction{funProjection=result}->return$result_->return$Nothing