{-# LANGUAGE CPP, ScopedTypeVariables #-}moduleAgda.Compiler.Epic.ForcingwhereimportControl.ApplicativeimportControl.Arrow(first,second)importControl.MonadimportControl.Monad.StateimportControl.Monad.TransimportData.CharimportData.Listhiding(sort)importqualifiedData.MapasMimportData.MaybeimportAgda.Syntax.CommonimportqualifiedAgda.Syntax.InternalasSIimportAgda.Syntax.LiteralimportAgda.Syntax.Position(noRange)importAgda.Syntax.Internal(Tele(..),Telescope,Term,Abs(..),unAbs,absName,Type,Args,QName,unEl)importAgda.TypeChecking.MonadimportAgda.TypeChecking.Rules.LHS.UnifyimportAgda.TypeChecking.Rules.LHS.InstantiateimportAgda.TypeChecking.Substitute(raiseFrom,raise,substs,apply,TelV(..))importqualifiedAgda.TypeChecking.SubstituteasSimportAgda.TypeChecking.PrettyasPimportAgda.TypeChecking.ReduceimportAgda.TypeChecking.TelescopeimportAgda.Utils.ListimportAgda.Utils.MonadimportAgda.Utils.PermutationimportAgda.Utils.SizeimportAgda.Compiler.Epic.AuxASTimportAgda.Compiler.Epic.CompileStateimportAgda.Compiler.Epic.EpicimportAgda.Compiler.Epic.InterfaceimportqualifiedAgda.Compiler.Epic.FromAgdaasFA#include "../../undefined.h"importAgda.Utils.Impossible-- | Returns how many parameters a datatype hasdataParameters::QName->CompileTCMNatdataParameters=lift.dataParametersTCM-- | Returns how many parameters a datatype hasdataParametersTCM::QName->TCMNatdataParametersTCMname=dom<-(gets(sigDefinitions.stImports))return$maybe__IMPOSSIBLE__(defnPars.theDef)(M.lookupnamem)wheredefnPars::Defn->NatdefnPars(Datatype{dataPars=p})=pdefnPars(Record{recPars=p})=pdefnParsd=0-- error (show d) -- __IMPOSSIBLE__ -- Not so sure about this.reportns=dolift$reportSDoc"epic.forcing"nspiApplyM'::Type->Args->TCMTypepiApplyM'tas=do{- reportSDoc "" 10 $ vcat
[ text "piApplyM'"
, text "type: " <+> prettyTCM t
, text "args: " <+> prettyTCM as
]-}piApplyMtas{- |
insertTele i xs t tele
tpos
tele := Gamma ; (i : T as) ; Delta
n := parameters T
xs' := xs `apply` (take n as)
becomes
tpos
( Gamma ; xs' ; Delta[i := t] --note that Delta still reference Gamma correctly
, T as ^ (size xs')
)
we raise the type since we have added xs' new bindings before Gamma, and as can
only bind to Gamma.
-}insertTele::(QName,Args)->Int-- ^ ABS `pos` in tele->MaybeType-- ^ If Just, it is the type to insert patterns from-- is nothing if we only want to delete a binding.->Term-- ^ Term to replace at pos->Telescope-- ^ The telescope `tele` where everything is at->CompileTCM(Telescope-- Resulting telescope,(Telescope,Type-- The type at pos in tele,Type-- The return Type of the inserted type))insertTelex0insterm(ExtendTeltto)=dot'<-lift$normalisetreport12$vcat[text"t' :"<+>prettyTCMt',text"term:"<+>prettyTCMterm,text"to:"<+>prettyTCM(unAbsto)](st,arg)<-caseSI.unEl.unArg$t'ofSI.Defstarg->return(st,arg)s->doreport10$vcat[text"ERROR!!!",text"found: "<+>(text.show)s,text"ins"<+>(prettyTCM.fromMaybe__IMPOSSIBLE__)ins]returnx-- Apply the parameters of the type of t-- Because: parameters occurs in the type of constructors but are not bound by it.pars<-dataParametersstreport10$text"apply in insertTele"TelVctelectyp<-lift$telView=<<maybe(return$unArgt')(`piApplyM'`take(fromIntegralpars)arg)ins()<-iflength(take(fromIntegralpars)arg)==fromIntegralparsthenreturn()else__IMPOSSIBLE__-- we deal with absBody to directly since we remove treturn(ctele+:+(S.substterm$S.raiseFrom1(sizectele)(unAbsto)),(ctele,S.raise(sizectele)$unArgt,ctyp))where-- Append the telescope, we raise since we add a new binding and all the previous-- bindings need to be preserved(+:+)::Telescope->Telescope->TelescopeEmptyTel+:+t2=t2ExtendTeltt1+:+t2=ExtendTelt(Abs(absNamet1)$unAbst1+:+{-raise 1-}t2)-- This case is impossible since we are trying to split a variable outside the teleinsertTelexninstermEmptyTel=__IMPOSSIBLE__insertTeleerninsterm(ExtendTelxxs)=do(xs',typ)<-insertTeleer(n-1)insterm(unAbsxs)return(ExtendTelx$Abs(absNamexs)xs',typ)mkConcn=SI.Conc[defaultArg$SI.Var(fromIntegrali)[]|i<-[n-1,n-2..0]]unifyI::Telescope->[Nat]->Type->Args->Args->CompileTCM[MaybeTerm]unifyIteleflextypa1a2=lift$addCtxTeltele$unifyIndices_flextypa1a2takeTele0_=EmptyTeltakeTelen(ExtendTeltts)=ExtendTelt$Abs(absNamets)$takeTele(n-1)(unAbsts)takeTele__=__IMPOSSIBLE__-- | Main function for removing pattern matching on forced variablesremForced::[Fun]->CompileTCM[Fun]remForcedfs=dodefs<-lift(gets(sigDefinitions.stImports))forMfs$\f->casefofFun{}->casefunQNamef>>=flipM.lookupdefsofNothing->__IMPOSSIBLE__Justdef->doTelVtele_<-lift$telView(defTypedef)report10$vcat[text"compiling fun"<+>(text.show)(funQNamef)]e<-forcedExpr(funArgsf)tele(funExprf)report10$vcat[text"compilied fun"<+>(text.show)(funQNamef),text"before:"<+>(text.prettyEpic)(funExprf),text"after:"<+>(text.prettyEpic)e]return$f{funExpr=e}EpicFun{}->returnf-- | For a given expression, in a certain telescope (the list of Var) is a mapping-- of variable name to the telescope.forcedExpr::[Var]->Telescope->Expr->CompileTCMExprforcedExprvarsteleexpr=caseexprofVar_->returnexprLit_->returnexprLamxe->Lamx<$>rece-- necessary?Contqes->Contq<$>mapMrecesAppves->Appv<$>mapMrecesIfabc->If<$>reca<*>recb<*>reccLetve1e2->Letv<$>rece1<*>rece2Lazye->Lazy<$>receUNIT->returnexprIMPOSSIBLE->returnexprCasev@(Varx)brs->doletn=fromMaybe__IMPOSSIBLE__$elemIndexxvars(Casev<$>).forMbrs$\br->casebrofBrIntie->do(tele'',_)<-insertTele__IMPOSSIBLE__nNothing(SI.Lit(LitCharnoRange(chri)))teleBrInti<$>forcedExpr(replaceAtnvars[])tele''eDefaulte->Default<$>receBranchtconstrase->dotyp<-getTypeconstrforc<-getForcedArgsconstr(tele'',(_,ntyp,ctyp))<-insertTele__IMPOSSIBLE__n(Justtyp)(mkConconstr(lengthas))telentyp<-lift$reducentypctyp<-lift$reducectypifnull(forcedforcas)thenBranchtconstras<$>forcedExpr(replaceAtnvarsas)tele''eelsedo-- unify the telescope type with the return type of the constructorunif<-case(unElntyp,unElctyp)of(SI.Defsta1,SI.Defst'a2)|st==st'->dotypPars<-fromIntegral<$>dataParametersstsetType<-getTypestreport10$vcat[text"ntyp:"<+>prettyTCMntyp,text"ctyp:"<+>prettyTCMctyp]unifyI(takeTele(n+lengthas)tele'')(mapfromIntegral$[0..n+lengthas])(setType`apply`taketypParsa1)(droptypParsa1)(droptypParsa2)_->__IMPOSSIBLE__letlower=map(raise(-1)).drop1isOkt=casetofSI.Varnxs|n>=0->all(isOk.unArg)xsSI.Con_xs->all(isOk.unArg)xsSI.Deffxs->all(isOk.unArg)xs_->error$showtsubT0tel=letss=[fromMaybe(SI.Varn[])t|(n,t)<-zip[0..](unif++repeatNothing)]in(S.substssstel,lowerss)subTn(ExtendTelat)=let(tb',ss)=subT(n-1)(unAbst)a'|allisOk(take100ss)=S.substsssa|True=__IMPOSSIBLE__in(ExtendTela$Abs(absNamet)tb',lowerss)subT__=__IMPOSSIBLE__(tele'''',_)=subT(n+lengthas)tele''report10$nest2$vcat[text"remforced",text"tele="<+>prettyTCMtele'',text"tele'="<+>prettyTCMtele'''',text"unif="<+>(text.show)unif,text"forced="<+>(text.show)(forcedforcas),text"constr"<+>prettyTCMconstr]-- replace all forced variables found using the unificationBranchtconstras<$>replaceForced(replaceAtnvarsas,reverse$takenvars++as)(tele'''')(forcedforcas)unife_->__IMPOSSIBLE__whererec=forcedExprvarstele-- | replace the forcedVar with pattern matching from the outside.replaceForced::([Var],[Var])->Telescope->[Var]->[MaybeSI.Term]->Expr->CompileTCMExprreplaceForced(vars,_)tele[]_e=forcedExprvarsteleereplaceForced(vars,uvars)tele(fvar:fvars)unife=doletn=fromMaybe__IMPOSSIBLE__$elemIndexfvaruvarsmpos<-findPosition(fromIntegraln)unifcasemposofNothing->caseunif!!nofNothing|fvar`notElem`fve->replaceForced(vars,uvars)telefvarsunifeNothing->doreport10$vcat[text"failure comming!",text"unif"<+>(text.show)unif,text"n"<+>(text.show)n,text"fvar"<+>(textfvar),text"fv"<+>(text.show)(fve)]__IMPOSSIBLE__Justt->dov<-newNamete<-FA.substTermuvarstsubstfvarv<$>replaceForced(vars,uvars)telefvarsunif(Letvtee)Just(pos,term)->do(build,v)<-buildTerm(uvars!!fromIntegerpos)(fromIntegraln)termbuild.substfvarv<$>replaceForced(vars,uvars)telefvarsunifewheresubfvarv=map$\x->ifx==fvarthenvelsex-- | Given a term containg the forced var, dig out the variable by inserting-- the proper case-expressions.buildTerm::Var->Nat->Term->CompileTCM(Expr->Expr,Var)buildTermvaridx(SI.Vari_)|idx==i=return(id,var)buildTermvaridx(SI.Concargs)=dovs<-replicateM(lengthargs)newName(pos,arg)<-fromMaybe__IMPOSSIBLE__<$>findPositionidx(map(Just.unArg)args)(fun',v)<-buildTerm(vs!!fromIntegerpos)idxargtag<-getConstrTagcletfune=casee(Varvar)[Branchtagcvse]return(fun.fun',v)buildTerm___=__IMPOSSIBLE__-- | Find the location where a certain Variable index is by searching the constructors-- aswell. i.e find a term that can be transformed into a pattern that contains the-- same value the index. This fails if no such term is present.findPosition::Nat->[MaybeSI.Term]->CompileTCM(Maybe(Nat,SI.Term))findPositionvarts=(listToMaybe.catMaybes<$>).forM(zip[0..]ts)$\(n,mt)->doifM(maybe(returnFalse)predmt)(return(Just(n,fromMaybe__IMPOSSIBLE__mt)))(returnNothing)wherepred::Term->CompileTCMBoolpredt=casetofSI.Vari_|var==i->returnTrueSI.Concargs->doforc<-getForcedArgscor<$>mapM(pred.unArg)(notForcedforcargs)_->returnFalse