modulePGF.Expr(Tree,BindType(..),Expr(..),Literal(..),Patt(..),Equation(..),readExpr,showExpr,pExpr,pBinds,ppExpr,ppPatt,pattScope,mkApp,unApp,mkStr,unStr,mkInt,unInt,mkDouble,unDouble,mkMeta,isMeta,normalForm,-- needed in the typecheckerValue(..),Env,Sig,eval,apply,value2expr,MetaId,-- helperspMeta,pArg,pLit,freshName,ppMeta,ppLit,ppParens)whereimportPGF.CIdimportPGF.TypeimportData.CharimportData.MaybeimportData.ListasListimportData.MapasMaphiding(showTree)importControl.MonadimportqualifiedText.PrettyPrintasPPimportqualifiedText.ParserCombinators.ReadPasRPdataLiteral=LStrString-- ^ string constant|LIntInt-- ^ integer constant|LFltDouble-- ^ floating point constantderiving(Eq,Ord,Show)typeMetaId=IntdataBindType=Explicit|Implicitderiving(Eq,Ord,Show)-- | Tree is the abstract syntax representation of a given sentence-- in some concrete syntax. Technically 'Tree' is a type synonym-- of 'Expr'.typeTree=Expr-- | An expression in the abstract syntax of the grammar. It could be-- both parameter of a dependent type or an abstract syntax tree for-- for some sentence.dataExpr=EAbsBindTypeCIdExpr-- ^ lambda abstraction|EAppExprExpr-- ^ application|ELitLiteral-- ^ literal|EMeta{-# UNPACK #-}!MetaId-- ^ meta variable|EFunCId-- ^ function or data constructor|EVar{-# UNPACK #-}!Int-- ^ variable with de Bruijn index|ETypedExprType-- ^ local type signature|EImplArgExpr-- ^ implicit argument in expressionderiving(Eq,Ord,Show)-- | The pattern is used to define equations in the abstract syntax of the grammar.dataPatt=PAppCId[Patt]-- ^ application. The identifier should be constructor i.e. defined with 'data'|PLitLiteral-- ^ literal|PVarCId-- ^ variable|PAsCIdPatt-- ^ variable@pattern|PWild-- ^ wildcard|PImplArgPatt-- ^ implicit argument in pattern|PTildeExprderivingShow-- | The equation is used to define lambda function as a sequence-- of equations with pattern matching. The list of 'Expr' represents-- the patterns and the second 'Expr' is the function body for this-- equation.dataEquation=Equ[Patt]ExprderivingShow-- | parses 'String' as an expressionreadExpr::String->MaybeExprreadExprs=case[x|(x,cs)<-RP.readP_to_SpExprs,allisSpacecs]of[x]->Justx_->Nothing-- | renders expression as 'String'. The list-- of identifiers is the list of all free variables-- in the expression in order reverse to the order-- of binding.showExpr::[CId]->Expr->StringshowExprvars=PP.render.ppExpr0varsinstanceReadExprwherereadsPrec_=RP.readP_to_SpExpr-- | Constructs an expression by applying a function to a list of expressionsmkApp::CId->[Expr]->ExprmkAppfes=foldlEApp(EFunf)es-- | Decomposes an expression into application of functionunApp::Expr->Maybe(CId,[Expr])unApp=extract[]whereextractes(EFunf)=Just(f,es)extractes(EAppe1e2)=extract(e2:es)e1extractes_=Nothing-- | Constructs an expression from string literalmkStr::String->ExprmkStrs=ELit(LStrs)-- | Decomposes an expression into string literalunStr::Expr->MaybeStringunStr(ELit(LStrs))=JustsunStr_=Nothing-- | Constructs an expression from integer literalmkInt::Int->ExprmkInti=ELit(LInti)-- | Decomposes an expression into integer literalunInt::Expr->MaybeIntunInt(ELit(LInti))=JustiunInt_=Nothing-- | Constructs an expression from real number literalmkDouble::Double->ExprmkDoublef=ELit(LFltf)-- | Decomposes an expression into real number literalunDouble::Expr->MaybeDoubleunDouble(ELit(LFltf))=JustfunDouble_=Nothing-- | Constructs an expression which is meta variablemkMeta::ExprmkMeta=EMeta0-- | Checks whether an expression is a meta variableisMeta::Expr->BoolisMeta(EMeta_)=TrueisMeta_=False------------------------------------------------------- Parsing-----------------------------------------------------pExpr::RP.ReadPExprpExpr=RP.skipSpaces>>(pAbsRP.<++pTerm)wherepTerm=dof<-pFactorRP.skipSpacesas<-RP.sepBypArgRP.skipSpacesreturn(foldlEAppfas)pAbs=doxs<-RP.between(RP.char'\\')(RP.skipSpaces>>RP.string"->")pBindse<-pExprreturn(foldr(\(b,x)e->EAbsbxe)exs)pBinds::RP.ReadP[(BindType,CId)]pBinds=doxss<-RP.sepBy1(RP.skipSpaces>>pBind)(RP.skipSpaces>>RP.char',')return(concatxss)wherepCIdOrWild=pCId`mplus`(RP.char'_'>>returnwildCId)pBind=dox<-pCIdOrWildreturn[(Explicit,x)]`mplus`RP.between(RP.char'{')(RP.skipSpaces>>RP.char'}')(RP.sepBy1(RP.skipSpaces>>pCIdOrWild>>=\id->return(Implicit,id))(RP.skipSpaces>>RP.char','))pArg=fmapEImplArg(RP.between(RP.char'{')(RP.char'}')pExpr)RP.<++pFactorpFactor=fmapEFunpCIdRP.<++fmapELitpLitRP.<++fmapEMetapMetaRP.<++RP.between(RP.char'(')(RP.char')')pExprRP.<++RP.between(RP.char'<')(RP.char'>')pTypedpTyped=doRP.skipSpacese<-pExprRP.skipSpacesRP.char':'RP.skipSpacesty<-pTypereturn(ETypedety)pMeta=doRP.char'?'ds<-RP.munchisDigitreturn(read('0':ds))pLit::RP.ReadPLiteralpLit=liftMLStr(RP.readS_to_Preads)RP.<++liftMLInt(RP.readS_to_Preads)RP.<++liftMLFlt(RP.readS_to_Preads)------------------------------------------------------- Printing-----------------------------------------------------ppExpr::Int->[CId]->Expr->PP.DocppExprdscope(EAbsbxe)=let(bs,xs,e1)=getVars[][](EAbsbxe)inppParens(d>1)(PP.char'\\'PP.<>PP.hsep(PP.punctuatePP.comma(reverse(List.zipWithppBindbsxs)))PP.<+>PP.text"->"PP.<+>ppExpr1(xs++scope)e1)wheregetVarsbsxs(EAbsbxe)=getVars(b:bs)((freshNamexxs):xs)egetVarsbsxse=(bs,xs,e)ppExprdscope(EAppe1e2)=ppParens(d>3)((ppExpr3scopee1)PP.<+>(ppExpr4scopee2))ppExprdscope(ELitl)=ppLitlppExprdscope(EMetan)=ppMetanppExprdscope(EFunf)=ppCIdfppExprdscope(EVari)=ppCId(scope!!i)ppExprdscope(ETypedety)=PP.char'<'PP.<>ppExpr0scopeePP.<+>PP.colonPP.<+>ppType0scopetyPP.<>PP.char'>'ppExprdscope(EImplArge)=PP.braces(ppExpr0scopee)ppPatt::Int->[CId]->Patt->PP.DocppPattdscope(PAppfps)=letds=List.map(ppPatt2scope)psinppParens(not(List.nullps)&&d>1)(ppCIdfPP.<+>PP.hsepds)ppPattdscope(PLitl)=ppLitlppPattdscope(PVarf)=ppCIdfppPattdscope(PAsxp)=ppCIdxPP.<>PP.char'@'PP.<>ppPatt3scopepppPattdscopePWild=PP.char'_'ppPattdscope(PImplArgp)=PP.braces(ppPatt0scopep)ppPattdscope(PTildee)=PP.char'~'PP.<>ppExpr6scopeepattScope::[CId]->Patt->[CId]pattScopescope(PAppfps)=foldlpattScopescopepspattScopescope(PLitl)=scopepattScopescope(PVarf)=f:scopepattScopescope(PAsxp)=pattScope(x:scope)ppattScopescopePWild=scopepattScopescope(PImplArgp)=pattScopescopeppattScopescope(PTildee)=scopeppBindExplicitx=ppCIdxppBindImplicitx=PP.braces(ppCIdx)ppLit(LStrs)=PP.text(shows)ppLit(LIntn)=PP.intnppLit(LFltd)=PP.doubledppMeta::MetaId->PP.DocppMetan|n==0=PP.char'?'|otherwise=PP.char'?'PP.<>PP.intnppParensTrue=PP.parensppParensFalse=idfreshName::CId->[CId]->CIdfreshNamexxs0=loop1xwherexs=wildCId:xs0loopiy|elemyxs=loop(i+1)(mkCId(showx++showi))|otherwise=y------------------------------------------------------- Computation------------------------------------------------------- | Compute an expression to normal formnormalForm::Sig->Int->Env->Expr->ExprnormalFormsigkenve=value2exprsigk(evalsigenve)value2exprsigi(VAppfvs)=foldlEApp(EFunf)(List.map(value2exprsigi)vs)value2exprsigi(VGenjvs)=foldlEApp(EVar(i-j-1))(List.map(value2exprsigi)vs)value2exprsigi(VMetajenvvs)=casesndsigjofJuste->value2exprsigi(applysigenvevs)Nothing->foldlEApp(EMetaj)(List.map(value2exprsigi)vs)value2exprsigi(VSuspjenvvsk)=value2exprsigi(k(VGenjvs))value2exprsigi(VConstfvs)=foldlEApp(EFunf)(List.map(value2exprsigi)vs)value2exprsigi(VLitl)=ELitlvalue2exprsigi(VClosureenv(EAbsbxe))=EAbsbx(value2exprsig(i+1)(evalsig((VGeni[]):env)e))value2exprsigi(VImplArgv)=EImplArg(value2exprsigiv)dataValue=VAppCId[Value]|VLitLiteral|VMeta{-# UNPACK #-}!MetaIdEnv[Value]|VSusp{-# UNPACK #-}!MetaIdEnv[Value](Value->Value)|VGen{-# UNPACK #-}!Int[Value]|VConstCId[Value]|VClosureEnvExpr|VImplArgValuetypeSig=(Map.MapCId(Type,Int,Maybe[Equation])-- type and def of a fun,Int->MaybeExpr-- lookup for metavariables)typeEnv=[Value]eval::Sig->Env->Expr->Valueevalsigenv(EVari)=env!!ievalsigenv(EFunf)=caseMap.lookupf(fstsig)ofJust(_,a,meqs)->casemeqsofJusteqs->ifa==0thencaseeqsofEqu[]e:_->evalsig[]e_->VConstf[]elseVAppf[]Nothing->VAppf[]Nothing->error("unknown function "++showCIdf)evalsigenv(EAppe1e2)=applysigenve1[evalsigenve2]evalsigenv(EAbsbxe)=VClosureenv(EAbsbxe)evalsigenv(EMetai)=casesndsigiofJuste->evalsigenveNothing->VMetaienv[]evalsigenv(ELitl)=VLitlevalsigenv(ETypede_)=evalsigenveevalsigenv(EImplArge)=VImplArg(evalsigenve)apply::Sig->Env->Expr->[Value]->Valueapplysigenve[]=evalsigenveapplysigenv(EVari)vs=applyValuesig(env!!i)vsapplysigenv(EFunf)vs=caseMap.lookupf(fstsig)ofJust(_,a,meqs)->casemeqsofJusteqs->ifa<=lengthvsthenmatchsigfeqsvselseVAppfvsNothing->VAppfvsNothing->error("unknown function "++showCIdf)applysigenv(EAppe1e2)vs=applysigenve1(evalsigenve2:vs)applysigenv(EAbs_xe)(v:vs)=applysig(v:env)evsapplysigenv(EMetai)vs=casesndsigiofJuste->applysigenvevsNothing->VMetaienvvsapplysigenv(ELitl)vs=error"literal of function type"applysigenv(ETypede_)vs=applysigenvevsapplysigenv(EImplArg_)vs=error"implicit argument in function position"applyValuesigv[]=vapplyValuesig(VAppfvs0)vs=applysig[](EFunf)(vs0++vs)applyValuesig(VLit_)vs=error"literal of function type"applyValuesig(VMetaienvvs0)vs=VMetaienv(vs0++vs)applyValuesig(VGenivs0)vs=VGeni(vs0++vs)applyValuesig(VSuspienvvs0k)vs=VSuspienvvs0(\v->applyValuesig(kv)vs)applyValuesig(VConstfvs0)vs=VConstf(vs0++vs)applyValuesig(VClosureenv(EAbsbxe))(v:vs)=applysig(v:env)evsapplyValuesig(VImplArg_)vs=error"implicit argument in function position"------------------------------------------------------- Pattern matching-----------------------------------------------------match::Sig->CId->[Equation]->[Value]->Valuematchsigfeqsas0=caseeqsof[]->VConstfas0(Equpsres):eqs->tryMatcheseqspsas0res[]wheretryMatcheseqs[]asresenv=applysigenvresastryMatcheseqs(p:ps)(a:as)resenv=tryMatchpaenvwheretryMatch(PVarx)(v)env=tryMatcheseqspsasres(v:env)tryMatch(PAsxp)(v)env=tryMatchpv(v:env)tryMatch(PWild)(_)env=tryMatcheseqspsasresenvtryMatch(p)(VMetaienvivs)env=VSuspienvivs(\v->tryMatchpvenv)tryMatch(p)(VGenivs)env=VConstfas0tryMatch(p)(VSuspienvivsk)env=VSuspienvivs(\v->tryMatchp(kv)env)tryMatch(p)v@(VConst__)env=VConstfas0tryMatch(PAppf1ps1)(VAppf2vs2)env|f1==f2=tryMatcheseqs(ps1++ps)(vs2++as)resenvtryMatch(PLitl1)(VLitl2)env|l1==l2=tryMatcheseqspsasresenvtryMatch(PImplArgp)(VImplArgv)env=tryMatchpvenvtryMatch(PTilde_)(_)env=tryMatcheseqspsasresenvtryMatch__env=matchsigfeqsas0