{-# LANGUAGE CPP, MultiParamTypeClasses, FunctionalDependencies,
FlexibleInstances, UndecidableInstances, OverlappingInstances
#-}{-| Translation from "Agda.Syntax.Concrete" to "Agda.Syntax.Abstract". Involves scope analysis,
figuring out infix operator precedences and tidying up definitions.
-}moduleAgda.Syntax.Translation.ConcreteToAbstract(ToAbstract(..),localToAbstract,concreteToAbstract_,concreteToAbstract,NewModuleQName(..),OldName(..),TopLevel(..),TopLevelInfo(..),topLevelModuleName,AbstractRHS,NewModuleName,OldModuleName,NewName,OldQName,LeftHandSide,RightHandSide,PatName,APatName,LetDef,LetDefs)whereimportPreludehiding(mapM)importControl.ApplicativeimportControl.Monad.Readerhiding(mapM)importControl.Monad.Errorhiding(mapM)importData.TypeableimportData.Traversable(mapM)importData.List((\\),nub)importqualifiedData.MapasMapimportAgda.Syntax.ConcreteasChiding(topLevelModuleName)importAgda.Syntax.Concrete.OperatorsimportAgda.Syntax.AbstractasAimportAgda.Syntax.PositionimportAgda.Syntax.CommonimportAgda.Syntax.InfoimportAgda.Syntax.Concrete.DefinitionsasCimportAgda.Syntax.Concrete.OperatorsimportAgda.Syntax.Concrete.PrettyimportAgda.Syntax.Abstract.PrettyimportAgda.Syntax.FixityimportAgda.Syntax.NotationimportAgda.Syntax.Scope.BaseimportAgda.Syntax.Scope.MonadimportAgda.Syntax.StrictimportAgda.TypeChecking.Monad.Base(TypeError(..),Call(..),typeError,TCErr(..),TCErr'(..),extendlambdaname)importAgda.TypeChecking.Monad.Trace(traceCall,traceCallCPS,setCurrentRange)importAgda.TypeChecking.Monad.StateimportAgda.TypeChecking.Monad.Optionsimport{-# SOURCE #-}Agda.Interaction.Imports(scopeCheckImport)importAgda.Interaction.OptionsimportAgda.Utils.MonadimportAgda.Utils.TupleimportAgda.Utils.ListimportAgda.Utils.FreshimportAgda.Utils.Pretty#include "../../undefined.h"importAgda.Utils.ImpossibleimportAgda.ImpossibleTest(impossibleTest){--------------------------------------------------------------------------
Exceptions
--------------------------------------------------------------------------}notAModuleExpre=typeError$NotAModuleExprenotAnExpressione=typeError$NotAnExpressionenotAValidLetBindingd=typeError$NotAValidLetBindingdnothingAppliedToHiddenArge=typeError$NothingAppliedToHiddenArgenothingAppliedToInstanceArge=typeError$NothingAppliedToInstanceArge-- DebuggingprintLocals::Int->String->ScopeM()printLocalsvs=verboseS"scope.top"v$dolocals<-getLocalVarsreportSLn""0$s++" "++showlocalsprintScope::String->Int->String->ScopeM()printScopetagvs=verboseS("scope."++tag)v$doscope<-getScopereportSLn""0$s++" "++showscope{--------------------------------------------------------------------------
Helpers
--------------------------------------------------------------------------}lhsArgs::C.Pattern->(C.Name,[NamedArgC.Pattern])lhsArgsp=caseappViewpofArg__(Named_(IdentP(C.QNamex))):ps->(x,ps)_->__IMPOSSIBLE__wheremkHead=ArgNotHiddenRelevant.unnamednotHidden=ArgNotHiddenRelevant.unnamedappViewp=casepofAppPparg->appViewp++[arg]OpAppP_xps->mkHead(IdentP$C.QNamex):mapnotHiddenpsParenP_p->appViewpRawAppP__->__IMPOSSIBLE___->[mkHeadp]annotateDecl::ScopeMA.Declaration->ScopeMA.DeclarationannotateDeclm=annotateDecls$(:[])<$>mannotateDecls::ScopeM[A.Declaration]->ScopeMA.DeclarationannotateDeclsm=dods<-ms<-getScopereturn$ScopedDeclsdsannotateExpr::ScopeMA.Expr->ScopeMA.ExprannotateExprm=doe<-ms<-getScopereturn$ScopedExprseexpandEllipsis::C.Pattern->[C.Pattern]->C.Clause->C.ClauseexpandEllipsis__c@(C.Clause_C.LHS{}___)=cexpandEllipsispps(C.Clausex(C.Ellipsis_ps'eqses)rhswhwcs)=C.Clausex(C.LHSp(ps++ps')eqses)rhswhwcs-- | Make sure that each variable occurs only once.checkPatternLinearity::[A.Pattern'e]->ScopeM()checkPatternLinearityps=casexs\\nubxsof[]->return()ys->typeError$RepeatedVariablesInPattern$nubyswherexs=concatMapvarspsvars::A.Pattern'e->[C.Name]varsp=casepofA.VarPx->[nameConcretex]A.ConP__args->concatMap(vars.namedThing.unArg)argsA.WildP_->[]A.AsP_xp->nameConcretex:varspA.DotP__->[]A.AbsurdP_->[]A.LitP_->[]A.DefP__args->__IMPOSSIBLE__A.ImplicitP_->__IMPOSSIBLE__-- | Compute the type of the record constructor (with bogus target type)recordConstructorType::[NiceDeclaration]->C.ExprrecordConstructorTypefields=buildfswherefs=reverse$dropWhilenotField$reversefieldsnotFieldNiceField{}=FalsenotField_=Truebuild(NiceFieldrf__x(Arghrele):fs)=C.Pi[C.TypedBindingsr$Arghrel(C.TBindr[BNamexf]e)]$buildfswherer=getRangexbuild(d:fs)=C.LetnoRange(notSoNiceDeclarations[d])$buildfsbuild[]=C.SetNnoRange0-- todo: nicercheckModuleApplication(C.SectionApp_tele)m0xdir'=withCurrentModulem0$do(m,args)<-caseappVieweofAppView(Identm)args->return(m,args)_->notAModuleExpretel'<-toAbstracttel(m1,args')<-toAbstract(OldModuleNamem,args)s<-getNamedScopem1-- Drop constructors (OnlyQualified) if there are arguments. The record constructor-- isn't properly in the record module, so copying it will lead to badness.letnoRecConstr|nullargs=id|otherwise=removeOnlyQualified(s',(renM,renD))<-copyScopem0.noRecConstr=<<getNamedScopem1s'<-applyImportDirectiveM(C.QNamex)dir's'modifyCurrentScope$consts'printScope"mod.inst"20"copied source module"reportSLn"scope.mod.inst"30$"renamings:\n "++showrenD++"\n "++showrenMreturn((A.SectionApptel'm1args'),renD,renM)checkModuleApplication(C.RecordModuleIFS_rec)m0xdir'=withCurrentModulem0$dom1<-toAbstract$OldModuleNamerecs<-getNamedScopem1(s',(renM,renD))<-copyScopem0ss'<-applyImportDirectiveMrecdir's'modifyCurrentScope$consts'printScope"mod.inst"20"copied record module"return((A.RecordModuleIFSm1),renD,renM)checkModuleMacroapplyrpxmodappopendir=withLocalVars$donotPublicWithoutOpenopendirm0<-toAbstract(NewModuleNamex)printScope"mod.inst"20"module macro"-- If we're opening, the import directive is applied to the open,-- otherwise to the module itself.letdir'=caseopenofDontOpen->dirDoOpen->defaultImportDir(modapp',renD,renM)<-checkModuleApplicationmodappm0xdir'bindModulepxm0printScope"mod.inst.copy.after"20"after copying"caseopenofDoOpen->openModule_(C.QNamex)dirDontOpen->return()printScope"mod.inst"20$showopenstripNoNamesprintScope"mod.inst"10$"after stripping"return[applyinfo(m0`withRangesOf`[x])modapp'renDrenM]whereinfo=ModuleInfo{minfoRange=r,minfoAsName=Nothing,minfoAsTo=renamingRangedir,minfoOpenShort=Justopen,minfoDirective=Justdir}-- | The @public@ keyword must only be used together with @open@.notPublicWithoutOpen::OpenShortHand->ImportDirective->ScopeM()notPublicWithoutOpenDoOpendir=return()notPublicWithoutOpenDontOpendir=when(publicOpendir)$typeError$GenericError"The public keyword must only be used together with the open keyword"-- | Computes the range of all the \"to\" keywords used in a renaming-- directive.renamingRange=getRange.maprenToRange.renaming{--------------------------------------------------------------------------
Translation
--------------------------------------------------------------------------}concreteToAbstract_::ToAbstractca=>c->ScopeMaconcreteToAbstract_x=toAbstractxconcreteToAbstract::ToAbstractca=>ScopeInfo->c->ScopeMaconcreteToAbstractscopex=withScope_scope(toAbstractx)-- | Things that can be translated to abstract syntax are instances of this-- class.classToAbstractconcreteabstract|concrete->abstractwheretoAbstract::concrete->ScopeMabstract-- | This function should be used instead of 'toAbstract' for things that need-- to keep track of precedences to make sure that we don't forget about it.toAbstractCtx::ToAbstractconcreteabstract=>Precedence->concrete->ScopeMabstracttoAbstractCtxctxc=withContextPrecedencectx$toAbstractcsetContextCPS::Precedence->(a->ScopeMb)->((a->ScopeMb)->ScopeMb)->ScopeMbsetContextCPSpretf=dop'<-getContextPrecedencewithContextPrecedencep$f$withContextPrecedencep'.retlocalToAbstractCtx::ToAbstractconcreteabstract=>Precedence->concrete->(abstract->ScopeMa)->ScopeMalocalToAbstractCtxctxcret=setContextCPSctxret(localToAbstractc)-- | This operation does not affect the scope, i.e. the original scope-- is restored upon completion.localToAbstract::ToAbstractca=>c->(a->ScopeMb)->ScopeMblocalToAbstractxret=fst<$>localToAbstract'xret-- | Like 'localToAbstract' but returns the scope after the completion of the-- second argument.localToAbstract'::ToAbstractca=>c->(a->ScopeMb)->ScopeM(b,ScopeInfo)localToAbstract'xret=doscope<-getScopewithScopescope$ret=<<toAbstractxinstance(ToAbstractc1a1,ToAbstractc2a2)=>ToAbstract(c1,c2)(a1,a2)wheretoAbstract(x,y)=(,)<$>toAbstractx<*>toAbstractyinstance(ToAbstractc1a1,ToAbstractc2a2,ToAbstractc3a3)=>ToAbstract(c1,c2,c3)(a1,a2,a3)wheretoAbstract(x,y,z)=flatten<$>toAbstract(x,(y,z))whereflatten(x,(y,z))=(x,y,z)instanceToAbstractca=>ToAbstract[c][a]wheretoAbstract=mapMtoAbstractinstanceToAbstractca=>ToAbstract(Maybec)(Maybea)wheretoAbstractNothing=returnNothingtoAbstract(Justx)=Just<$>toAbstractx-- Names ------------------------------------------------------------------newtypeNewNamea=NewNameanewtypeOldQName=OldQNameC.QNamenewtypeOldName=OldNameC.NamenewtypePatName=PatNameC.QNameinstanceToAbstract(NewNameC.Name)A.NamewheretoAbstract(NewNamex)=doy<-freshAbstractName_xbindVariablexyreturnyinstanceToAbstract(NewNameC.BoundName)A.NamewheretoAbstract(NewName(BNamexfx))=doy<-freshAbstractNamefxxbindVariablexyreturnynameExpr::AbstractName->A.ExprnameExprd=mk(anameKindd)$anameNamedwheremkDefName=DefmkConName=Con.AmbQ.(:[])instanceToAbstractOldQNameA.ExprwheretoAbstract(OldQNamex)=doqx<-resolveNamexreportSLn"scope.name"10$"resolved "++showx++": "++showqxcaseqxofVarNamex'->return$A.Varx'DefinedName_d->return$nameExprdConstructorNameds->return$A.Con$AmbQ(mapanameNameds)UnknownName->notInScopexdataAPatName=VarPatNameA.Name|ConPatName[AbstractName]instanceToAbstractPatNameAPatNamewheretoAbstract(PatNamex)=doreportSLn"scope.pat"10$"checking pattern name: "++showxrx<-resolveNamexz<-case(rx,x)of-- TODO: warn about shadowing(VarNamey,C.QNamex)->return$Leftx-- typeError $ RepeatedVariableInPattern y x(DefinedName_d,C.QNamex)|DefName==anameKindd->return$Leftx(UnknownName,C.QNamex)->return$Leftx(ConstructorNameds,_)->return$Rightds_->typeError$GenericError$"Cannot pattern match on "++showx++", because it is not a constructor"casezofLeftx->doreportSLn"scope.pat"10$"it was a var: "++showxp<-VarPatName<$>toAbstract(NewNamex)printLocals10"bound it:"returnpRightcs->doreportSLn"scope.pat"10$"it was a con: "++show(mapanameNamecs)return$ConPatNamecs-- Should be a defined name.instanceToAbstractOldNameA.QNamewheretoAbstract(OldNamex)=dorx<-resolveName(C.QNamex)caserxofDefinedName_d->return$anameNamed_->error$showx++" - "++showrxnewtypeNewModuleName=NewModuleNameC.NamenewtypeNewModuleQName=NewModuleQNameC.QNamenewtypeOldModuleName=OldModuleNameC.QNamefreshQModule::A.ModuleName->C.Name->ScopeMA.ModuleNamefreshQModulemx=A.qualifyMm.mnameFromList.(:[])<$>freshAbstractName_xcheckForModuleClash::C.Name->ScopeM()checkForModuleClashx=doms<-scopeLookup(C.QNamex)<$>getScopeunless(nullms)$setCurrentRange(getRangex)$typeError$ShadowedModule$map((`withRangeOf`x).amodName)msinstanceToAbstractNewModuleNameA.ModuleNamewheretoAbstract(NewModuleNamex)=docheckForModuleClashxm<-getCurrentModuley<-freshQModulemxcreateModuleyreturnyinstanceToAbstractNewModuleQNameA.ModuleNamewheretoAbstract(NewModuleQNamem)=toAbsnoModuleNamemwheretoAbsm(C.QNamex)=doy<-freshQModulemxcreateModuleyreturnytoAbsm(C.Qualxq)=dom'<-freshQModulemxtoAbsm'qinstanceToAbstractOldModuleNameA.ModuleNamewheretoAbstract(OldModuleNameq)=amodName<$>resolveModuleq-- Expressions -------------------------------------------------------------- | Peel off 'C.HiddenArg' and represent it as an 'NamedArg'.mkNamedArg::C.Expr->NamedArgC.ExprmkNamedArg(C.HiddenArg_e)=ArgHiddenRelevantemkNamedArg(C.InstanceArg_e)=ArgInstanceRelevantemkNamedArge=ArgNotHiddenRelevant$unnamede-- | Peel off 'C.HiddenArg' and represent it as an 'Arg', throwing away any name.mkArg'::Relevance->C.Expr->ArgC.ExprmkArg'r(C.HiddenArg_e)=ArgHiddenr$namedThingemkArg'r(C.InstanceArg_e)=ArgInstancer$namedThingemkArg're=ArgNotHiddenre-- | By default, arguments are @Relevant@.mkArg::C.Expr->ArgC.Expr-- mkArg (C.Dot _ e) = mkArg' Irrelevant emkArge=mkArg'Relevante-- | Parse a possibly dotted C.Expr as A.Expr. Bool = True if dotted.toAbstractDot::Precedence->C.Expr->ScopeM(A.Expr,Bool)toAbstractDotprece=doreportSLn"scope.irrelevance"100$"toAbstractDot: "++(render$prettye)traceCall(ScopeCheckExpre)$caseeof-- annotateExpr e = ScopedExpr <scope from Monad> eC.Dot_e->doe<-toAbstractCtxprecereturn(e,True)C.RawAppres->doe<-parseApplicationestoAbstractDotpreceC.Paren_e->toAbstractDotTopCtxee->doe<-toAbstractCtxprecereturn(e,False)toAbstractOpArg::Precedence->OpAppC.Expr->ScopeMA.ExprtoAbstractOpArgctx(Ordinarye)=toAbstractCtxctxetoAbstractOpArgctx(SyntaxBindingLambdarbse)=toAbstractLamrbsectxtoAbstractLam::Range->[C.LamBinding]->C.Expr->Precedence->ScopeMA.ExprtoAbstractLamrbsectx=dolocalToAbstract(mapmakeDomainFullbs)$\bs->casebsofb:bs'->doe<-toAbstractCtxctxeletinfo=ExprRangerreturn$A.Laminfob$foldrmkLamebs'wheremkLambe=A.Lam(ExprRange$fuseRangebe)be[]->__IMPOSSIBLE__instanceToAbstractC.ExprA.ExprwheretoAbstracte=traceCall(ScopeCheckExpre)$annotateExpr$caseeof-- annotateExpr e = ScopedExpr <scope from Monad> e-- NamesIdentx->toAbstract(OldQNamex)-- LiteralsC.Litl->return$A.Litl-- Meta variablesC.QuestionMarkrn->doscope<-getScopereturn$A.QuestionMark$MetaInfo{metaRange=r,metaScope=scope,metaNumber=n}C.Underscorern->doscope<-getScopereturn$A.Underscore$MetaInfo{metaRange=r,metaScope=scope,metaNumber=n}-- Raw applicationC.RawAppres->doe<-parseApplicationestoAbstracte{- Andreas, 2010-09-06 STALE COMMENT
-- Dots are used in dot patterns and in irrelevant function space .A n -> B
-- we propagate dots out from the head of applications
C.Dot r e1 -> do
t1 <- toAbstract e1
return $ A.Dot t1
-}-- ApplicationC.Appre1e2->doe1<-toAbstractCtxFunctionCtxe1e2<-toAbstractCtxArgumentCtxe2return$A.App(ExprRanger)e1e2-- Operator applicationC.OpAppropes->toAbstractOpAppopes-- With applicationC.WithApprees->doe<-toAbstractCtxWithFunCtxees<-mapM(toAbstractCtxWithArgCtx)esreturn$A.WithApp(ExprRanger)ees-- Malplaced hidden argumentC.HiddenArg__->nothingAppliedToHiddenArgeC.InstanceArg__->nothingAppliedToInstanceArge-- LambdaC.AbsurdLamrh->return$A.AbsurdLam(ExprRanger)hC.Lamrbse->toAbstractLamrbseTopCtx-- Extended LambdaC.ExtendedLamrcs->do-- m <- getCurrentModulecname<-nextlamnamer0extendlambdanamename<-freshAbstractName_cnamereportSLn"toabstract.extendlambda"10$"new extended lambda name: "++shownameqname<-qualifyName_namebindNamePrivateAccessDefNamecnameqnameletinsertApp(C.RawAppPres)=C.RawAppPr((IdentP(C.QNamecname)):es)insertApp(C.IdentPq)=C.RawAppP(getRangeq)((IdentP(C.QNamecname)):[C.IdentPq])insertApp_=__IMPOSSIBLE__insertHead(C.LHSpwpseqswith)=C.LHS(insertAppp)wpseqswithinsertHead(C.Ellipsisrwpseqswith)=C.Ellipsisrwpseqswithscdef<-toAbstract(C.FunDefr[]defaultFixity'ConcreteDefcname(map(\(lhs,rhs,wh)->-- wh = NoWhere, see parser for more infoC.Clausecname(insertHeadlhs)rhswh[])cs))casescdefof(A.ScopedDeclsi[A.FunDefdiqname'cs])->dosetScopesireturn$A.ExtendedLam(ExprRanger)diqname'cs_->__IMPOSSIBLE__wherenextlamname::Range->Int->String->ScopeMC.Namenextlamnameris=doletcname_pre=C.Namer[Id$s++showi]rn<-resolveName(C.QNamecname_pre)casernofUnknownName->return$cname_pre_->nextlamnamer(i+1)s-- Irrelevant non-dependent function typeC.Funre1e2->doArghrel(e0,dotted)<-fmapM(toAbstractDotFunctionSpaceDomainCtx)$mkArge1lete1=Argh(ifdottedthenIrrelevantelserel)e0e2<-toAbstractCtxTopCtxe2letinfo=ExprRangerreturn$A.Funinfoe1e2{-
-- Other function types
C.Fun r e1 e2 -> do
e1 <- toAbstractCtx FunctionSpaceDomainCtx $ mkArg e1
e2 <- toAbstractCtx TopCtx e2
let info = ExprRange r
return $ A.Fun info e1 e2
-}e0@(C.Pitele)->localToAbstracttel$\tel->doe<-toAbstractCtxTopCtxeletinfo=ExprRange(getRangee0)return$A.Piinfotele-- SortsC.Set_->return$A.Set(ExprRange$getRangee)0C.SetN_n->return$A.Set(ExprRange$getRangee)nC.Prop_->return$A.Prop$ExprRange$getRangee-- Lete0@(C.Let_dse)->localToAbstract(LetDefsds)$\ds'->doe<-toAbstractCtxTopCtxeletinfo=ExprRange(getRangee0)return$A.Letinfods'e-- Record constructionC.Recrfs->dolet(xs,es)=unzipfses<-toAbstractCtxTopCtxesreturn$A.Rec(ExprRanger)$zipxses-- Record updateC.RecUpdaterefs->dolet(xs,es)=unzipfse<-toAbstractees<-toAbstractCtxTopCtxesreturn$A.RecUpdate(ExprRanger)e$zipxses-- ParenthesisC.Paren_e->toAbstractCtxTopCtxe-- Pattern thingsC.Dot__->notAnExpressioneC.As___->notAnExpressioneC.Absurd_->notAnExpressione-- Impossible thingsC.ETel_->__IMPOSSIBLE__-- QuotingC.QuoteGoal_xe->dox'<-toAbstract(NewNamex)e'<-toAbstractereturn$A.QuoteGoal(ExprRange$getRangee)x'e'C.Quoter->return$A.Quote(ExprRanger)C.QuoteTermr->return$A.QuoteTerm(ExprRanger)C.Unquoter->return$A.Unquote(ExprRanger)-- DontCareC.DontCaree->A.DontCare<$>toAbstracteinstanceToAbstractC.LamBindingA.LamBindingwheretoAbstract(C.DomainFreehrelx)=A.DomainFreehrel<$>toAbstract(NewNamex)toAbstract(C.DomainFulltb)=A.DomainFull<$>toAbstracttbmakeDomainFull::C.LamBinding->C.LamBindingmakeDomainFullb@C.DomainFull{}=bmakeDomainFull(C.DomainFreehrelx)=C.DomainFull$C.TypedBindingsr$Arghrel$C.TBindr[x]$C.UnderscorerNothingwherer=getRangexinstanceToAbstractC.TypedBindingsA.TypedBindingswheretoAbstract(C.TypedBindingsrbs)=A.TypedBindingsr<$>toAbstractbsinstanceToAbstractC.TypedBindingA.TypedBindingwheretoAbstract(C.TBindrxst)=dot'<-toAbstractCtxTopCtxtxs'<-toAbstract(mapNewNamexs)return$A.TBindrxs't'toAbstract(C.TNoBinde)=doe<-toAbstractCtxTopCtxereturn(A.TNoBinde)-- | Returns the scope inside the checked module.scopeCheckModule::Range->C.QName->A.ModuleName->C.Telescope->[C.Declaration]->ScopeM(ScopeInfo,[A.Declaration])scopeCheckModulerxqmtelds=doprintScope"module"20$"checking module "++showxres<-withCurrentModuleqm$do-- pushScope m-- qm <- getCurrentModuleprintScope"module"20$"inside module "++showxwithLocalVars$dotel<-toAbstracttelds<-(:[]).A.Sectioninfo(qm`withRangesOfQ`x)tel<$>toAbstractdsscope<-getScopereturn(scope,ds)-- Binding is done by the callerprintScope"module"20$"after module "++showxreturnreswhereinfo=ModuleInfornoRangeNothingNothingNothingnewtypeTopLevela=TopLeveladataTopLevelInfo=TopLevelInfo{topLevelDecls::[A.Declaration],outsideScope::ScopeInfo,insideScope::ScopeInfo}-- | The top-level module name.topLevelModuleName::TopLevelInfo->A.ModuleNametopLevelModuleNametopLevel=scopeCurrent(insideScopetopLevel)-- Top-level declarations are always (import|open)* moduleinstanceToAbstract(TopLevel[C.Declaration])TopLevelInfowheretoAbstract(TopLevelds)=casesplitAt(lengthds-1)dsof(ds',[C.Modulermtelds])->dosetTopLevelModulemam<-toAbstract(NewModuleQNamem)ds'<-toAbstractds'(scope0,ds)<-scopeCheckModulermamteldsscope<-getScopereturn$TopLevelInfo(ds'++ds)scopescope0_->__IMPOSSIBLE__-- | runs Syntax.Concrete.Definitions.niceDeclarations on main moduleniceDecls::[C.Declaration]->ScopeM[NiceDeclaration]niceDeclsds=caserunNice$niceDeclarationsdsofLefte->throwError$TCErrNothing$Exception(getRangee)(showe)Rightds->returndsinstanceToAbstract[C.Declaration][A.Declaration]wheretoAbstractds=toAbstract=<<niceDeclsdsnewtypeLetDefs=LetDefs[C.Declaration]newtypeLetDef=LetDefNiceDeclarationinstanceToAbstractLetDefs[A.LetBinding]wheretoAbstract(LetDefsds)=concat<$>(toAbstract=<<mapLetDef<$>niceDeclsds)instanceToAbstractLetDef[A.LetBinding]wheretoAbstract(LetDefd)=casedofNiceMutual_d@[C.FunSig_fx_relxt,C.FunDef___abstract_[cl]]->dowhen(abstract==AbstractDef)$dotypeError$GenericError$"abstract not allowed in let expressions"e<-letToAbstractclt<-toAbstracttx<-toAbstract(NewName$C.BNamexfx)return[A.LetBind(LetRange$getRanged)relxte]-- You can't open public in a letNiceOpenrxdirs|not(C.publicOpendirs)->dom<-toAbstract(OldModuleNamex)n<-length.scopeLocals<$>getScopeopenModule_xdirsreturn[A.LetOpen(ModuleInfo{minfoRange=r,minfoAsName=Nothing,minfoAsTo=renamingRangedirs,minfoOpenShort=Nothing,minfoDirective=Justdirs})m]NiceModuleMacrorpaxmodappopendir|not(C.publicOpendir)->checkModuleMacroLetApplyrpxmodappopendir_->notAValidLetBindingdwhereletToAbstract(C.Clausetopclhs@(C.LHSp[][][])(C.RHSrhs)NoWhere[])=dop<-parseLHS(Justtop)plocalToAbstract(snd$lhsArgsp)$\args->dorhs<-toAbstractrhsfoldMlambdarhs(reverseargs)-- just reverse because these DomainFreeletToAbstract_=notAValidLetBindingd-- Named patterns not allowed in let definitionslambdae(Arghrel(NamedNothing(A.VarPx)))=return$A.Lami(A.DomainFreehrelx)ewherei=ExprRange(fuseRangexe)lambdae(Arghrel(NamedNothing(A.WildPi)))=dox<-freshNoName(getRangei)return$A.Lami'(A.DomainFreehrelx)ewherei'=ExprRange(fuseRangeie)lambda__=notAValidLetBindingd-- The only reason why we return a list is that open declarations disappears.-- For every other declaration we get a singleton list.instanceToAbstractNiceDeclarationA.DeclarationwheretoAbstractd=annotateDecls$traceCall(ScopeCheckDeclarationd)$casedof-- AxiomC.Axiomrfprelxt->doclo<-commandLineOptionswhen(optSafeclo)(typeError(SafeFlagPostulatex))t'<-toAbstractCtxTopCtxty<-freshAbstractQNamefxbindNamepDefNamexyreturn[A.Axiom(mkDefInfoxfpConcreteDefr)relyt']-- FieldsC.NiceFieldrfpaxt->dot'<-toAbstractCtxTopCtxty<-freshAbstractQNamefxirrProj<-optIrrelevantProjections<$>pragmaOptionsunless(argRelevancet==Irrelevant&&notirrProj)$-- Andreas, 2010-09-24: irrelevant fields are not in scope-- this ensures that projections out of irrelevant fields cannot occur-- Ulf: unless you turn on --irrelevant-projectionsbindNamepDefNamexyreturn[A.Field(mkDefInfoxfpar)yt']-- Primitive functionPrimitiveFunctionrfpaxt->dot'<-toAbstractCtxTopCtxty<-freshAbstractQNamefxbindNamepDefNamexyreturn[A.Primitive(mkDefInfoxfpar)yt']-- Definitions (possibly mutual)NiceMutualrds->dods'<-toAbstractdsreturn[A.Mutual(DeclInfoC.noName_r)ds']-- TODO: what does the info mean here?C.NiceRecSigrfaxlst->withLocalVars$dolettoTypeBinding::C.LamBinding->C.TypedBindingstoTypeBindingb=casemakeDomainFullbofC.DomainFullb->b_->__IMPOSSIBLE__ls'<-toAbstract(maptoTypeBindingls)x'<-freshAbstractQNamefxbindNameaDefNamexx't'<-toAbstracttreturn[A.RecSig(mkDefInfoxfaConcreteDefr)x'ls't']C.NiceDataSigrfaxlst->withLocalVars$doprintScope"scope.data.sig"20("checking DataSig for "++showx)lettoTypeBinding::C.LamBinding->C.TypedBindingstoTypeBindingb=casemakeDomainFullbofC.DomainFullb->b_->__IMPOSSIBLE__ls'<-toAbstract(maptoTypeBindingls)x'<-freshAbstractQNamefxbindNameaDefNamexx't'<-toAbstracttreturn[A.DataSig(mkDefInfoxfaConcreteDefr)x'ls't']-- Type signaturesC.FunSigrfprelxt->(:[])<$>toAbstract(C.Axiomrfprelxt)-- Function definitionsC.FunDefrdsfaxcs->doprintLocals10$"checking def "++showx(x',cs')<-toAbstract(OldNamex,cs)return[A.FunDef(mkDefInfoxfPublicAccessar)x'cs']-- Data definitionsC.DataDefrfaxparscons->withLocalVars$doprintScope"scope.data.def"20("checking DataDef for "++showx)-- Check for duplicate constructorsdoletcs=mapconNameconsdups=nub$cs\\nubcsbad=filter(`elem`dups)csunless(distinctcs)$setCurrentRange(getRangebad)$typeError$DuplicateConstructorsdupspars<-toAbstractparsDefinedNamepax<-resolveName(C.QNamex)letx'=anameNameax-- Create the module for the qualified constructorscheckForModuleClashx-- disallow shadowing previously defined modulesletm=mnameFromList$qnameToListx'createModulembindModulepxm-- make it a proper modulecons<-toAbstract(map(ConstrDeclNoRecmap)cons)-- Open the module-- openModule_ (C.QName x) defaultImportDir{ publicOpen = True }printScope"data"20$"Checked data "++showxreturn[A.DataDef(mkDefInfoxfPublicAccessar)x'parscons]whereconName(C.Axiom____c_)=cconName_=__IMPOSSIBLE__-- Record definitions (mucho interesting)C.RecDefrfaxcmparsfields->withLocalVars$do-- Check that the generated module doesn't clash with a previously-- defined modulecheckForModuleClashxpars<-toAbstractparsDefinedNamepax<-resolveName(C.QNamex)letx'=anameNameaxcontel<-toAbstract$recordConstructorTypefieldsm0<-getCurrentModuleletm=A.qualifyMm0$mnameFromList$(:[])$last$qnameToListx'printScope"rec"15"before record"createModulemafields<-withCurrentModulem$doafields<-toAbstractfieldsprintScope"rec"15"checked fields"returnafieldsbindModulepxmcm'<-mapM(\(ThingWithFixitycf)->bindConstructorNamemcfapYesRec)cmprintScope"rec"15"record complete"return[A.RecDef(mkDefInfoxfPublicAccessar)x'cm'parscontelafields]NiceModulerpa(C.QNamename)telds->traceCall(ScopeCheckDeclaration$NiceModulerpa(C.QNamename)tel[])$doaname<-toAbstract(NewModuleNamename)x<-snd<$>scopeCheckModuler(C.QNamename)anameteldsbindModulepnameanamereturnxNiceModule___C.Qual{}__->__IMPOSSIBLE__NiceModuleMacrorpaxmodappopendir->checkModuleMacroApplyrpxmodappopendirNiceOpenrxdir->dom<-toAbstract(OldModuleNamex)printScope"open"20$"opening "++showxopenModule_xdirprintScope"open"20$"result:"return[A.Open(ModuleInfo{minfoRange=r,minfoAsName=Nothing,minfoAsTo=renamingRangedir,minfoOpenShort=Nothing,minfoDirective=Justdir})m]NicePragmarp->dops<-toAbstractpreturn$map(A.Pragmar)psNiceImportrxasopendir->donotPublicWithoutOpenopendir-- First scope check the imported module and return its name and-- interface. This is done with that module as the top-level module.-- This is quite subtle. We rely on the fact that when setting the-- top-level module and generating a fresh module name the generated-- name will be exactly the same as the name generated when checking-- the imported module.(m,i)<-withCurrentModulenoModuleName$withTopLevelModulex$dom<-toAbstract$NewModuleQNamexprintScope"import"10"before import:"(m,i)<-scopeCheckImportmprintScope"import"10$"scope checked import: "++showi-- We don't want the top scope of the imported module (things happening-- before the module declaration)return(m,Map.deletenoModuleNamei)-- Merge the imported scopes with the current scopesmodifyScopeInfo$\s->s{scopeModules=Map.unionWithmergeScope(Map.deletem$scopeModuless)i}-- Bind the desired module name to the right abstract name.caseasofNothing->bindQModulePrivateAccessxmJusty->bindModulePrivateAccess(asNamey)mprintScope"import"10"merged imported sig:"-- Open if specified, otherwise apply import directiveslet(name,theAsSymbol,theAsName)=caseasofNothing->(x,noRange,Nothing)Justa->(C.QName(asNamea),asRangea,Just(asNamea))caseopenofDoOpen->dotoAbstract[C.Openrnamedir]return()DontOpen->do-- If not opening import directives are applied to the original scopemodifyNamedScopeMm$applyImportDirectiveMxdirreturn[A.Import(ModuleInfo{minfoRange=r,minfoAsName=theAsName,minfoAsTo=getRange(theAsSymbol,renamingRangedir),minfoOpenShort=Justopen,minfoDirective=Justdir})m]dataIsRecordCon=YesRec|NoRecdataConstrDecl=ConstrDeclIsRecordConA.ModuleNameIsAbstractAccessC.NiceDeclarationbindConstructorNamemxfaprec=do-- The abstract name is the qualified oney<-withCurrentModulem$freshAbstractQNamefx-- Bind it twice, once unqualified and once qualifiedbindNamep'ConNamexywithCurrentModulem$bindNamep''ConNamexyreturnywhere-- An abstract constructor is private (abstract constructor means-- abstract datatype, so the constructor should not be exported).p'=caseaofAbstractDef->PrivateAccess_->pp''=case(a,rec)of(AbstractDef,_)->PrivateAccess(_,YesRec)->OnlyQualified-- record constructors aren't really in the record module_->PublicAccessinstanceToAbstractConstrDeclA.DeclarationwheretoAbstract(ConstrDeclrecmap(C.Axiomrf_relxt))=do-- rel==Relevantt'<-toAbstractCtxTopCtxt-- The abstract name is the qualified one-- Bind it twice, once unqualified and once qualifiedy<-bindConstructorNamemxfaprecprintScope"con"15"bound constructor"return$A.Axiom(mkDefInfoxfpConcreteDefr)relyt'toAbstract_=__IMPOSSIBLE__-- a constructor is always an axiominstanceToAbstractC.Pragma[A.Pragma]wheretoAbstract(C.ImpossiblePragma_)=impossibleTesttoAbstract(C.OptionsPragma_opts)=return[A.OptionsPragmaopts]toAbstract(C.CompiledTypePragma_xhs)=doe<-toAbstract$OldQNamexcaseeofA.Defx->return[A.CompiledTypePragmaxhs]_->fail$"Bad compiled type: "++showx-- TODO: error messagetoAbstract(C.CompiledDataPragma_xhshcs)=doe<-toAbstract$OldQNamexcaseeofA.Defx->return[A.CompiledDataPragmaxhshcs]_->fail$"Not a datatype: "++showx-- TODO: error messagetoAbstract(C.CompiledPragma_xhs)=doe<-toAbstract$OldQNamexy<-caseeofA.Defx->returnxA.Con_->fail"Use COMPILED_DATA for constructors"-- TODO_->__IMPOSSIBLE__return[A.CompiledPragmayhs]toAbstract(C.CompiledEpicPragma_xep)=doe<-toAbstract$OldQNamexy<-caseeofA.Defx->returnx_->__IMPOSSIBLE__return[A.CompiledEpicPragmayep]toAbstract(C.CompiledJSPragma_xep)=doe<-toAbstract$OldQNamexy<-caseeofA.Defx->returnxA.Con(AmbQ[x])->returnxA.Conx->fail("COMPILED_JS used on ambiguous name "++showx)_->__IMPOSSIBLE__return[A.CompiledJSPragmayep]toAbstract(C.StaticPragma_x)=doe<-toAbstract$OldQNamexy<-caseeofA.Defx->returnx_->__IMPOSSIBLE__return[A.StaticPragmay]toAbstract(C.BuiltinPragma_be)=doe<-toAbstractereturn[A.BuiltinPragmabe]toAbstract(C.ImportPragma_i)=doaddHaskellImportireturn[]toAbstract(C.EtaPragma_x)=doe<-toAbstract$OldQNamexcaseeofA.Defx->return[A.EtaPragmax]_->fail"Bad ETA pragma"instanceToAbstractC.ClauseA.ClausewheretoAbstract(C.ClausetopC.Ellipsis{}___)=fail"bad '...'"-- TODO: errors messagetoAbstract(C.Clausetoplhs@(C.LHSpwpseqswith)rhswhwcs)=withLocalVars$doletwcs'=map(expandEllipsispwps)wcslhs'<-toAbstract(LeftHandSidetoppwps)printLocals10"after lhs:"let(whname,whds)=casewhofNoWhere->(Nothing,[])AnyWhereds->(Nothing,ds)SomeWheremds->(Justm,ds)ifnot(nulleqs)thendorhs<-toAbstract=<<toAbstractCtxTopCtx(RightHandSideeqswithwcs'rhswhds)return$A.Clauselhs'rhs[]elsedo-- the right hand side is checked inside the module of the local definitions(rhs,ds)<-whereToAbstract(getRangewh)whnamewhds$toAbstractCtxTopCtx(RightHandSideeqswithwcs'rhs[])rhs<-toAbstractrhsreturn$A.Clauselhs'rhsdswhereToAbstract::Range->MaybeC.Name->[C.Declaration]->ScopeMa->ScopeM(a,[A.Declaration])whereToAbstract__[]inner=dox<-innerreturn(x,[])whereToAbstractrwhnamewhdsinner=dom<-maybe(nameConcrete<$>freshNoNamenoRange)returnwhnameletacc=maybePrivateAccess(constPublicAccess)whname-- unnamed where's are privatelettel=[]old<-getCurrentModuleam<-toAbstract(NewModuleNamem)(scope,ds)<-scopeCheckModuler(C.QNamem)amtelwhdssetScopescopex<-innersetCurrentModuleoldbindModuleaccmamreturn(x,ds)dataRightHandSide=RightHandSide[C.Expr][C.Expr][C.Clause]C.RHS[C.Declaration]dataAbstractRHS=AbsurdRHS'|WithRHS'[A.Expr][C.Clause]-- ^ The with clauses haven't been translated yet|RHS'A.Expr|RewriteRHS'[A.Expr]AbstractRHS[A.Declaration]qualifyName_::A.Name->ScopeMA.QNamequalifyName_x=dom<-getCurrentModulereturn$A.qualifymxwithFunctionName::String->ScopeMA.QNamewithFunctionNames=doNameIdi_<-freshqualifyName_=<<freshName_(s++showi)instanceToAbstractAbstractRHSA.RHSwheretoAbstractAbsurdRHS'=returnA.AbsurdRHStoAbstract(RHS'e)=return$A.RHSetoAbstract(RewriteRHS'eqsrhswh)=doauxs<-replicateM(lengtheqs)$withFunctionName"rewrite-"rhs<-toAbstractrhsreturn$RewriteRHSauxseqsrhswhtoAbstract(WithRHS'escs)=doaux<-withFunctionName"with-"A.WithRHSauxes<$>toAbstractcsinstanceToAbstractRightHandSideAbstractRHSwheretoAbstract(RightHandSideeqs@(_:_)escsrhswh)=doeqs<-toAbstractCtxTopCtxeqs-- TODO: remember named where(rhs,ds)<-whereToAbstract(getRangewh)Nothingwh$toAbstract(RightHandSide[]escsrhs[])return$RewriteRHS'eqsrhsdstoAbstract(RightHandSide[][](_:_)__)=__IMPOSSIBLE__toAbstract(RightHandSide[](_:_)_(C.RHS_)_)=typeError$BothWithAndRHStoAbstract(RightHandSide[][][]rhs[])=toAbstractrhstoAbstract(RightHandSide[]escsC.AbsurdRHS[])=does<-toAbstractCtxTopCtxesreturn$WithRHS'escs-- TODO: some of these might be possibletoAbstract(RightHandSide[](_:_)_C.AbsurdRHS(_:_))=__IMPOSSIBLE__toAbstract(RightHandSide[][][](C.RHS_)(_:_))=__IMPOSSIBLE__toAbstract(RightHandSide[][][]C.AbsurdRHS(_:_))=__IMPOSSIBLE__instanceToAbstractC.RHSAbstractRHSwheretoAbstractC.AbsurdRHS=return$AbsurdRHS'toAbstract(C.RHSe)=RHS'<$>toAbstractedataLeftHandSide=LeftHandSideC.NameC.Pattern[C.Pattern]instanceToAbstractLeftHandSideA.LHSwheretoAbstract(LeftHandSidetoplhswps)=traceCall(ScopeCheckLHStoplhs)$dop<-parseLHS(Justtop)lhsprintLocals10"before lhs:"let(x,ps)=lhsArgspx<-withLocalVars$setLocalVars[]>>toAbstract(OldNamex)args<-toAbstractpswps<-toAbstract=<<mapM(parseLHSNothing)wpscheckPatternLinearity(map(namedThing.unArg)args++wps)printLocals10"checked pattern:"args<-toAbstractargs-- take care of dot patternswps<-toAbstractwpsprintLocals10"checked dots:"return$A.LHS(LHSRange$getRange(lhs,wps))xargswpsinstanceToAbstractca=>ToAbstract(Argc)(Arga)wheretoAbstract(Arghre)=Arghr<$>toAbstractCtx(hiddenArgumentCtxh)einstanceToAbstractca=>ToAbstract(Namednamec)(Namednamea)wheretoAbstract(Namedne)=Namedn<$>toAbstracte-- Patterns are done in two phases. First everything but the dot patterns, and-- then the dot patterns. This is because dot patterns can refer to variables-- bound anywhere in the pattern.instanceToAbstractca=>ToAbstract(A.Pattern'c)(A.Pattern'a)wheretoAbstract=mapMtoAbstractinstanceToAbstractC.Pattern(A.Pattern'C.Expr)wheretoAbstractp@(C.IdentPx)=dopx<-toAbstract(PatNamex)casepxofVarPatNamey->return$VarPyConPatNameds->return$ConP(PatRange(getRangep))(AmbQ$mapanameNameds)[]toAbstractp0@(AppPpq)=do(p',q')<-toAbstract(p,q)casep'ofConP_xas->return$ConPinfox(as++[q'])DefP_xas->return$DefPinfox(as++[q'])_->typeError$InvalidPatternp0wherer=getRangep0info=PatSourcer$\pr->ifappBracketsprthenParenPrp0elsep0toAbstractp0@(OpAppPropps)=dop<-toAbstract(IdentP$C.QNameop)ps<-toAbstractpscasepofConP_xas->return$ConPinfox(as++map(ArgNotHiddenRelevant.unnamed)ps)DefP_xas->return$DefPinfox(as++map(ArgNotHiddenRelevant.unnamed)ps)_->__IMPOSSIBLE__wherer=getRangep0info=PatSourcer$\pr->ifappBracketsprthenParenPrp0elsep0-- Removed when parsingtoAbstract(HiddenP__)=__IMPOSSIBLE__toAbstract(InstanceP__)=__IMPOSSIBLE__toAbstract(RawAppP__)=__IMPOSSIBLE__toAbstractp@(C.WildPr)=return$A.WildP(PatSourcer$constp)toAbstract(C.ParenP_p)=toAbstractptoAbstract(C.LitPl)=return$A.LitPltoAbstractp0@(C.AsPrxp)=typeError$NotSupported"@-patterns"{- do
x <- toAbstract (NewName x)
p <- toAbstract p
return $ A.AsP info x p
where
info = PatSource r $ \_ -> p0
-}-- we have to do dot patterns at the endtoAbstractp0@(C.DotPre)=return$A.DotPinfoewhereinfo=PatSourcer$\_->p0toAbstractp0@(C.AbsurdPr)=return$A.AbsurdPinfowhereinfo=PatSourcer$\_->p0-- | Turn an operator application into abstract syntax. Make sure to record the-- right precedences for the various arguments.toAbstractOpApp::C.Name->[OpAppC.Expr]->ScopeMA.ExprtoAbstractOpAppop@(C.NoName__)es=__IMPOSSIBLE__toAbstractOpAppop@(C.Name__)es=dof<-getFixity(C.QNameop)let(_,_,parts)=oldToNewNotation$(op,f)op<-toAbstract(OldQName$C.QNameop)foldlappop<$>left(theFixityf)[p|p<-parts,not(isBindingHolep)]eswhereappearg=A.App(ExprRange(fuseRangeearg))e$ArgNotHiddenRelevant$unnamedargleftf(IdPart_:xs)es=insidefxsesleftf(_:xs)(e:es)=doe<-toAbstractOpArg(LeftOperandCtxf)ees<-insidefxsesreturn(e:es)leftf(_:_)[]=__IMPOSSIBLE__leftf[]_=__IMPOSSIBLE__insidef[x]es=rightfxesinsidef(IdPart_:xs)es=insidefxsesinsidef(_:xs)(e:es)=doe<-toAbstractOpArgInsideOperandCtxees<-insidefxsesreturn(e:es)inside_(_:_)[]=__IMPOSSIBLE__inside_[]_=__IMPOSSIBLE__right_(IdPart_)[]=return[]rightf_[e]=doe<-toAbstractOpArg(RightOperandCtxf)ereturn[e]right___=__IMPOSSIBLE__