{-# LANGUAGE CPP, RelaxedPolyRec #-}moduleAgda.TypeChecking.MetaVarswhereimportControl.Monad.ReaderimportControl.Monad.StateimportControl.Monad.ErrorimportData.GenericsimportData.Map(Map)importData.Set(Set)importData.ListasListhiding(sort)importqualifiedData.MapasMapimportqualifiedData.SetasSetimportqualifiedAgda.Utils.IO.LocaleasLocIOimportAgda.Syntax.CommonimportqualifiedAgda.Syntax.InfoasInfoimportAgda.Syntax.InternalimportAgda.Syntax.PositionimportAgda.Syntax.LiteralimportqualifiedAgda.Syntax.AbstractasAimportAgda.TypeChecking.MonadimportAgda.TypeChecking.Monad.BuiltinimportAgda.TypeChecking.ReduceimportAgda.TypeChecking.SubstituteimportAgda.TypeChecking.ConstraintsimportAgda.TypeChecking.ErrorsimportAgda.TypeChecking.FreeimportAgda.TypeChecking.RecordsimportAgda.TypeChecking.PrettyimportAgda.TypeChecking.EtaContractimportAgda.TypeChecking.MetaVars.Occursimport{-# SOURCE #-}Agda.TypeChecking.ConversionimportAgda.Utils.FreshimportAgda.Utils.ListimportAgda.Utils.MonadimportAgda.Utils.SizeimportAgda.Utils.PermutationimportAgda.TypeChecking.Monad.Debug#include "../undefined.h"importAgda.Utils.Impossible-- | Find position of a value in a list.-- Used to change metavar argument indices during assignment.---- @reverse@ is necessary because we are directly abstracting over the list.--findIdx::Eqa=>[a]->a->MaybeIntfindIdxvsv=findIndex(==v)(reversevs)-- | Check whether a meta variable is a place holder for a blocked term.isBlockedTerm::MonadTCMtcm=>MetaId->tcmBoolisBlockedTermx=doreportSLn"tc.meta.blocked"12$"is "++showx++" a blocked term? "i<-mvInstantiation<$>lookupMetaxletr=caseiofBlockedConst{}->TruePostponedTypeCheckingProblem{}->TrueInstV{}->FalseInstS{}->FalseOpen{}->FalsereportSLn"tc.meta.blocked"12$ifrthen" yes, because "++showielse" no"returnrisEtaExpandable::MonadTCMtcm=>MetaId->tcmBoolisEtaExpandablex=doi<-mvInstantiation<$>lookupMetaxreturn$caseiofOpen{}->TrueInstV{}->FalseInstS{}->FalseBlockedConst{}->FalsePostponedTypeCheckingProblem{}->FalseclassHasMetatwheremetaInstance::MonadTCMtcm=>t->tcmMetaInstantiationmetaVariable::MetaId->Args->tinstanceHasMetaTermwheremetaInstance=return.InstVmetaVariable=MetaVinstanceHasMetaSortwheremetaInstance=return.InstS.SortmetaVariable=MetaS-- TODO(=:=)::(MonadTCMtcm)=>MetaId->Term->tcm()x=:=t=doreportSLn"tc.meta.assign"70$showx++" := "++showtstore<-getMetaStoremodify$\st->st{stMetaStore=insx(InstS$killRanget)store}etaExpandListenersxwakeupConstraintsreportSLn"tc.meta.assign"20$"completed assignment of "++showxwhereinsxistore=Map.adjust(insti)xstoreinstimv=mv{mvInstantiation=i}-- | The instantiation should not be an 'InstV' or 'InstS' and the 'MetaId'-- should point to something 'Open' or a 'BlockedConst'.(=:)::(MonadTCMtcm,HasMetat,KillRanget,Showt)=>MetaId->t->tcm()x=:t=doreportSLn"tc.meta.assign"70$showx++" := "++showti<-metaInstance(killRanget)store<-getMetaStoremodify$\st->st{stMetaStore=insxistore}etaExpandListenersxwakeupConstraintsreportSLn"tc.meta.assign"20$"completed assignment of "++showxwhereinsxistore=Map.adjust(insti)xstoreinstimv=mv{mvInstantiation=i}assignTerm::MonadTCMtcm=>MetaId->Term->tcm()assignTerm=(=:)assignSort::MonadTCMtcm=>MetaId->Sort->tcm()assignSort=(=:)newSortMeta::MonadTCMtcm=>tcmSortnewSortMeta=ifMtypeInType(return$mkType0)$ifMhasUniversePolymorphism(newSortMetaCtx=<<getContextArgs)$doi<-createMetaInfox<-newMetainormalMetaPriority(idP0)(IsSort())return$MetaSx[]newSortMetaCtx::MonadTCMtcm=>Args->tcmSortnewSortMetaCtxvs=ifMtypeInType(return$mkType0)$doi<-createMetaInfox<-newMetainormalMetaPriority(idP0)(IsSort())return$MetaSxvsnewTypeMeta::MonadTCMtcm=>Sort->tcmTypenewTypeMetas=Els<$>newValueMeta(sorts)newTypeMeta_::MonadTCMtcm=>tcmTypenewTypeMeta_=newTypeMeta=<<newSortMeta-- | Create a new metavariable, possibly η-expanding in the process.newValueMeta::MonadTCMtcm=>Type->tcmTermnewValueMetat=dovs<-getContextArgstel<-getContextTelescopenewValueMetaCtx(telePi_telt)vsnewValueMetaCtx::MonadTCMtcm=>Type->Args->tcmTermnewValueMetaCtxtctx=dom@(MetaVi_)<-newValueMetaCtx'tctxinstantiateFullm-- | Create a new value meta without η-expanding.newValueMeta'::MonadTCMtcm=>Type->tcmTermnewValueMeta't=dovs<-getContextArgstel<-getContextTelescopenewValueMetaCtx'(telePi_telt)vs-- | Create a new value meta with specific dependencies.newValueMetaCtx'::MonadTCMtcm=>Type->Args->tcmTermnewValueMetaCtx'tvs=doi<-createMetaInfoletTelVtel_=telView'tperm=idP(sizetel)x<-newMetainormalMetaPriorityperm(HasType()t)reportSDoc"tc.meta.new"50$fsep[text"new meta:",nest2$prettyTCMvs<+>text"|-",nest2$text(showx)<+>text":"<+>prettyTCMt]etaExpandMetaSafexreturn$MetaVxvsnewTelMeta::MonadTCMtcm=>Telescope->tcmArgsnewTelMetatel=newArgsMeta(abstracttel$ElProp$SortProp)newArgsMeta::MonadTCMtcm=>Type->tcmArgsnewArgsMetat=doargs<-getContextArgstel<-getContextTelescopenewArgsMetaCtxttelargsnewArgsMetaCtx::MonadTCMtcm=>Type->Telescope->Args->tcmArgsnewArgsMetaCtx(Elstm)telctx=dotm<-reducetmcasefunViewtmofFunV(Arghra)_->doarg<-(Arghr)<$>{-
-- Andreas, 2010-09-24 skip irrelevant record fields when eta-expanding a meta var
-- Andreas, 2010-10-11 this is WRONG, see Issue 347
if r == Irrelevant then return DontCare else
-}newValueMetaCtx(telePi_tela)ctxargs<-newArgsMetaCtx(Elstm`piApply`[arg])telctxreturn$arg:argsNoFunV_->return[]-- | Create a metavariable of record type. This is actually one metavariable-- for each field.newRecordMeta::MonadTCMtcm=>QName->Args->tcmTermnewRecordMetarpars=doargs<-getContextArgstel<-getContextTelescopenewRecordMetaCtxrparstelargsnewRecordMetaCtx::MonadTCMtcm=>QName->Args->Telescope->Args->tcmTermnewRecordMetaCtxrparstelctx=doftel<-flipapplypars<$>getRecordFieldTypesrfields<-newArgsMetaCtx(telePi_ftel$sortProp)telctxcon<-getRecordConstructorrreturn$ConconfieldsnewQuestionMark::MonadTCMtcm=>Type->tcmTermnewQuestionMarkt=dom@(MetaVx_)<-newValueMeta'tii<-freshaddInteractionPointiixreturnm-- | Construct a blocked constant if there are constraints.blockTerm::MonadTCMtcm=>Type->Term->tcmConstraints->tcmTermblockTermtvm=docs<-solveConstraints=<<mifList.nullcsthenreturnvelsedoi<-createMetaInfovs<-getContextArgstel<-getContextTelescopex<-newMeta'(BlockedConst$abstracttelv)ilowMetaPriority(idP$sizetel)(HasType()$telePi_telt)-- we don't instantiate blocked termsc<-escapeContext(sizetel)$guardConstraint(returncs)(UnBlockx)verboseS"tc.meta.blocked"20$dodx<-prettyTCM(MetaVx[])dv<-escapeContext(sizetel)$prettyTCM$abstracttelvdcs<-mapMprettyTCMcsliftIO$LocIO.putStrLn$"blocked "++showdx++" := "++showdvliftIO$LocIO.putStrLn$" by "++showdcsaddConstraintscreturn$MetaVxvs-- | Auxiliary function to create a postponed type checking problem.unblockedTester::MonadTCMtcm=>Type->tcmBoolunblockedTestert=dot<-reduceB$unEltcasetofBlocked{}->returnFalseNotBlockedMetaV{}->returnFalse_->returnTruepostponeTypeCheckingProblem_::MonadTCMtcm=>A.Expr->Type->tcmTermpostponeTypeCheckingProblem_et=dopostponeTypeCheckingProblemet(unblockedTestert)postponeTypeCheckingProblem::MonadTCMtcm=>A.Expr->Type->TCMBool->tcmTermpostponeTypeCheckingProblemetunblock=doi<-createMetaInfotel<-getContextTelescopecl<-buildClosure(e,t,unblock)m<-newMeta'(PostponedTypeCheckingProblemcl)inormalMetaPriority(idP(sizetel))$HasType()$telePi_teltaddConstraints=<<buildConstraint(UnBlockm)MetaVm<$>getContextArgs-- | Eta expand metavariables listening on the current meta.etaExpandListeners::MonadTCMtcm=>MetaId->tcm()etaExpandListenersm=doms<-getMetaListenersmclearMetaListenersm-- we don't really have to do this-- Andreas 2010-10-15: do not expand record mvars, lazyness needed for irrelevancemapM_etaExpandMetaSafems-- mapM_ (etaExpandMeta allMetaKinds) ms-- | Do safe eta-expansions for meta (@SingletonRecords,Levels@).etaExpandMetaSafe::MonadTCMtcm=>MetaId->tcm()etaExpandMetaSafe=etaExpandMeta[SingletonRecords,Levels]-- | Various kinds of metavariables.dataMetaKind=Records-- ^ Meta variables of record type.|SingletonRecords-- ^ Meta variables of \"hereditarily singleton\" record type.|Levels-- ^ Meta variables of level type, if type-in-type is activated.deriving(Eq,Enum,Bounded)-- | All possible metavariable kinds.allMetaKinds::[MetaKind]allMetaKinds=[minBound..maxBound]-- | Eta expand a metavariable, if it is of the specified kind.-- Don't do anything if the metavariable is a blocked term.etaExpandMeta::MonadTCMtcm=>[MetaKind]->MetaId->tcm()etaExpandMetakindsm=whenM(isEtaExpandablem)$doverboseBracket"tc.meta.eta"20("etaExpandMeta "++showm)$dometa<-lookupMetamletHasType_a=mvJudgementmetaTelVtelb<-telViewMaletargs=[Arghr$Vari[]|(i,Arghr_)<-reverse$zip[0..]$reverse$telToListtel]bb<-reduceBbcaseunEl<$>bbofBlockedx_->listenToMetamxNotBlocked(MetaVx_)->listenToMetamxNotBlockedlvl@(Defrps)->ifM(isEtaRecordr)(doletexpand=dou<-withMetaInfo(mvInfometa)$newRecordMetaCtxrpstelargsinContext[]$addCtxTeltel$doverboseS"tc.meta.eta"15$dodu<-prettyTCMuliftIO$LocIO.putStrLn$"eta expanding: "++showm++" --> "++showdunoConstraints$assignVbmargsu-- should never produce any constraintsifRecords`elem`kindsthenexpandelseifSingletonRecords`elem`kindsthendosingleton<-isSingletonRecordrpscasesingletonofLeftx->listenToMetamxRightFalse->return()RightTrue->expandelsereturn())$when(Levels`elem`kinds)$domlvl<-getBuiltin'builtinLeveltt<-typeInTypeiftt&&Justlvl==mlvlthendoreportSLn"tc.meta.eta"20$"Expanding level meta to 0 (type-in-type)"noConstraints$assignVbmargs(Lit$LitLevelnoRange0)elsereturn()_->return()-- | Eta expand blocking metavariables of record type, and reduce the-- blocked thing.etaExpandBlocked::(MonadTCMtcm,Reducet)=>Blockedt->tcm(Blockedt)etaExpandBlockedt@NotBlocked{}=returntetaExpandBlocked(Blockedmt)=doetaExpandMeta[Records]mt<-reduceBtcasetofBlockedm'_|m/=m'->etaExpandBlockedt_->returntabortAssign::MonadTCMtcm=>tcmaabortAssign=dos<-getliftTCM$throwError$TCErrNothing$AbortAssignshandleAbort::MonadTCMtcm=>TCMa->TCMa->tcmahandleAborthm=liftTCM$m`catchError_`\e->caseerrErroreofAbortAssigns->doputs;hPatternErr{}->do-- Andreas, 2010-09-17 uncommenting the reportSLn statements-- breaks something. Why?-- reportSLn "tc.meta.assign" 50 "handleAbort: Pattern violation!"throwErrore_->do-- reportSLn "tc.meta.assign" 50 "handleAbort: Some exception"throwErrore-- | Assign to an open metavar.-- First check that metavar args are in pattern fragment.-- Then do extended occurs check on given thing.--assignV::MonadTCMtcm=>Type->MetaId->Args->Term->tcmConstraintsassignVtxargsv=handleAborthandler$doreportSDoc"tc.meta.assign"10$dotext"term"<+>prettyTCM(MetaVxargs)<+>text":="<+>prettyTCMvv<-normalisevcasevofSortInf->typeError$GenericError"Setω is not a valid type."_->return()-- We don't instantiate blocked termswhenM(isBlockedTermx)patternViolation-- TODO: not so nice-- Check that the arguments are distinct variables-- Andreas, 2010-09-24: Herein, ignore the variables which are not-- free in vletfvs=allVars$freeVarsvreportSDoc"tc.meta.assign"20$letpr(Varn[])=text(shown)pr(Defc[])=prettyTCMcpr_=text".."invcat[text"mvar args:"<+>sep(map(pr.unArg)args),text"fvars rhs:"<+>sep(map(text.show)$Set.toListfvs)]ids<-checkArgsxargsfvsreportSDoc"tc.meta.assign"15$text"preparing to instantiate: "<+>prettyTCMv-- Andreas, 2010-10-15 I want to see whether rhd is blockedreportSDoc"tc.meta.assign"25$dov0<-reduceBvcasev0ofBlockedm0_->text"blocked on:"<+>prettyTCMm0NotBlocked{}->text"not blocked"-- Check that the x doesn't occur in the right hand sidev<-liftTCM$occursCheckx(mapunArgids)vverboseS"tc.conv.assign"30$doletn=sizevwhen(n>200)$dor<-getMetaRangexd<-sep[text"size"<+>text(shown),nest2$text"type"<+>prettyTCMt,nest2$text"term"<+>prettyTCMv]liftIO$LocIO.printdreportSLn"tc.meta.assign"15"passed occursCheck"-- Rename the variables in v to make it suitable for abstraction over ids.v'<-do-- Basically, if-- Γ = a b c d e-- ids = d b e-- then-- v' = (λ a b c d e. v) _ 1 _ 2 0tel<-getContextTelescopeargs<-mapdefaultArg<$>getContextTermsletiargs=reverse$zipWith(rename$reverse$mapunArgids)[0..]$reverseargsv'=raise(sizeids)(abstracttelv)`apply`iargsreturnv'letextTel(Arghri)m=dotel<-mt<-typeOfBVix<-nameOfBVireturn$ExtendTel(Arghrt)(Abs(showx)tel)tel'<-foldrextTel(returnEmptyTel)idsreportSDoc"tc.meta.assign"15$text"final instantiation:"<+>prettyTCM(abstracttel'v')-- Perform the assignment (and wake constraints). Metas-- are top-level so we do the assignment at top-level.n<-size<$>getContextTelescopeescapeContextn$x=:killRange(abstracttel'v')return[]whererenameidsiarg=casefindIndex(==i)idsofJustj->fmap(const$Var(fromIntegralj)[])argNothing->fmap(const__IMPOSSIBLE__)arg-- we will end up here, but never look at the resulthandler::MonadTCMtcm=>tcmConstraintshandler=doreportSLn"tc.meta.assign"10$"Oops. Undo "++showx++" := ..."equalTermt(MetaVxargs)v-- TODO: Unify with assignVassignS::MonadTCMtcm=>MetaId->Args->Sort->tcmConstraintsassignSxargss=ifM(not<$>hasUniversePolymorphism)(noPolyAssignxs)$handleAborthandler$doreportSDoc"tc.meta.assign"10$dotext"sort"<+>prettyTCM(MetaSxargs)<+>text":="<+>prettyTCMs-- We don't instantiate blocked termswhenM(isBlockedTermx)patternViolation-- TODO: not so nice-- Check that the arguments are distinct variablesreportSDoc"tc.meta.assign"20$letpr(Varn[])=text(shown)pr(Defc[])=prettyTCMcpr_=text".."intext"args:"<+>sep(map(pr.unArg)args)-- TODO Hackletfvs=freeVarsswhen(any(<0)$Set.toList(flexibleVarsfvs))$doreportSLn"tc.meta.assign"10"negative variables!"patternViolationids<-checkArgsxargs(allVarsfvs)reportSDoc"tc.meta.assign"15$text"preparing to instantiate: "<+>prettyTCMs-- Check that the x doesn't occur in the right hand sidev<-liftTCM$occursCheckx(mapunArgids)(Sorts)verboseS"tc.conv.assign"30$doletn=sizevwhen(n>200)$dor<-getMetaRangexd<-sep[text"size"<+>text(shown),nest2$text"sort"<+>prettyTCMv]liftIO$LocIO.printdreportSLn"tc.meta.assign"15"passed occursCheck"-- Rename the variables in v to make it suitable for abstraction over ids.v'<-do-- Basically, if-- Γ = a b c d e-- ids = d b e-- then-- v' = (λ a b c d e. v) _ 1 _ 2 0tel<-getContextTelescopeargs<-mapdefaultArg<$>getContextTermsletiargs=reverse$zipWith(rename$reverse$mapunArgids)[0..]$reverseargsv'=raise(sizeids)(abstracttelv)`apply`iargsreturnv'letextTel(Arghri)m=dotel<-mt<-typeOfBVix<-nameOfBVireturn$ExtendTel(Arghrt)(Abs(showx)tel)tel'<-foldrextTel(returnEmptyTel)idsreportSDoc"tc.meta.assign"15$text"final instantiation:"<+>prettyTCM(abstracttel'v')-- Perform the assignment (and wake constraints). Metas-- are top-level so we do the assignment at top-level.n<-size<$>getContextTelescopeescapeContextn$x=:=killRange(abstracttel'v')return[]whererenameidsiarg=casefindIndex(==i)idsofJustj->fmap(const$Var(fromIntegralj)[])argNothing->fmap(const__IMPOSSIBLE__)arg-- we will end up here, but never look at the resulthandler::MonadTCMtcm=>tcmConstraintshandler=doreportSLn"tc.meta.assign"10$"Oops. Undo "++showx++" := ..."equalSort(MetaSxargs)snoPolyAssignxs=handleAbort(equalSort(MetaSx[])s)$doSorts<-occursCheckx[](Sorts)x=:sreturn[]typeFVs=SetNat-- | Check that arguments to a metavar are in pattern fragment.-- Assumes all arguments already in whnf.-- Parameters are represented as @Var@s so @checkArgs@ really-- checks that all args are unique @Var@s and returns the-- list of corresponding indices for each arg-- done-- to not define equality on @Term@.---- @reverse@ is necessary because we are directly abstracting over this list @ids@.--checkArgs::MonadTCMtcm=>MetaId->Args->FVs->tcm[ArgNat]checkArgsxargsfvs=doargs<-instantiateFullargscasevalidParametersargsfvsofJustids->return$reverseidsNothing->patternViolation-- | Check that the parameters to a meta variable are distinct variables.-- Andreas, 2010-09-24: Allow non-linear variables that do not appear in @FVs@.validParameters::Monadm=>Args->FVs->m[ArgNat]validParametersargsfvs|allisVarargs&&distinct(filter(flipSet.memberfvs)$mapunArgvars)=return$reversevars|otherwise=fail"invalid parameters"wherevars=[Arghri|Arghr(Vari[])<-args]isVar::ArgTerm->BoolisVar(Arg__(Var_[]))=TrueisVar_=FalseupdateMeta::(MonadTCMtcm,Dataa,Occursa,Abstracta)=>MetaId->a->tcm()updateMetamIt=domv<-lookupMetamIwithMetaInfo(getMetaInfomv)$doargs<-getContextArgscs<-updmIargs(mvJudgementmv)tunless(List.nullcs)$fail$"failed to update meta "++showmIwhereupdmIargsjt=(__IMPOSSIBLE__`mkQ`updVj`extQ`updS)twhereupdV(HasType_t)v=assignV(t`piApply`args)mIargsvupdV__=__IMPOSSIBLE__updSs=assignSmIargss