>{-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances #-}>-- | >-- Module : Ivor.ViewTerm>-- Copyright : Edwin Brady>-- Licence : BSD-style (see LICENSE in the distribution)>-->-- Maintainer : eb@dcs.st-and.ac.uk>-- Stability : experimental>-- Portability : non-portable>-- >-- Exported view of terms and inductive data structures; imported >-- implicitly by "Ivor.TT".>moduleIvor.ViewTerm(-- * Variable names>Name,name,displayName,NameType(..),mkVar,>-- * Terms>Term(..),ViewTerm(..),Annot(..),apply,>view,viewType,ViewConst,typeof,>freeIn,namesIn,occursIn,subst,getApp,>Ivor.ViewTerm.getFnArgs,transform,>getArgTypes,Ivor.ViewTerm.getReturnType,>dbgshow,>-- * Inductive types>Inductive(..))>where>importIvor.TTCoreasTTCorehiding(subst)>importIvor.Gadgets>importIvor.State>importIvor.Typecheck>importData.Typeable>importData.List>importData.Binary>importControl.Monad>importDebug.Trace>name::String->Name>name=UN>displayName::Name->String>displayName(UNx)=x>displayName(MN(x,i))="_"++x++"_"++showi>-- | Abstract type representing a TT term and its type.>newtypeTerm=Term(IndexedName,IndexedName)>instanceShowTermwhere>show(Term(Indtm,Indty))>=show(makePstm)++" : "++show(makePsty)++"\n">-- | Categories for names; typechecked terms will know what each variable>-- is for. >dataNameType=Bound|Free|DataCon|TypeCon|ElimOp>|Unknown-- ^ Use for sending to typechecker.>deriving(Show,Enum)>-- | Construct a term representing a variable>mkVar::String-- ^ Variable name>->ViewTerm>mkVarnm=NameUnknown(namenm)>dataViewTerm>=Name{nametype::NameType,var::Name}>|App{fun::ViewTerm,arg::ViewTerm}>|Lambda{var::Name,vartype::ViewTerm,scope::ViewTerm}>|Forall{var::Name,vartype::ViewTerm,scope::ViewTerm}>|Let{var::Name,vartype::ViewTerm,>varval::ViewTerm,scope::ViewTerm}>|Label{fname::Name,fargs::[ViewTerm],labeltype::ViewTerm}>|Call{fname::Name,fargs::[ViewTerm],callterm::ViewTerm}>|Return{returnterm::ViewTerm}>|forallc.Constantc=>Constantc>|Star>|Quote{quotedterm::ViewTerm}-- ^ Staging annotation>|Code{codetype::ViewTerm}-- ^ Staging annotation>|Eval{evalterm::ViewTerm}-- ^ Staging annotation>|Escape{escapedterm::ViewTerm}-- ^ Staging annotation>|Placeholder>|Annotation{annotation::Annot,>term::ViewTerm}-- ^ additional annotations>|Metavar{var::Name}>dataAnnot=FileLocFilePathInt-- ^ source file, line number>instanceEqViewTermwhere>(==)(Name_x)(Name_y)=x==y>(==)(Ivor.ViewTerm.Appfa)(Ivor.ViewTerm.Appf'a')=f==f'&&a==a'>(==)(Ivor.ViewTerm.Lambdantysc)(Ivor.ViewTerm.Lambdan'ty'sc')=n==n'&&ty==ty'&&sc==sc'>(==)(Forallntysc)(Foralln'ty'sc')=n==n'&&ty==ty'&&sc==sc'>(==)(Ivor.ViewTerm.Letnvtysc)(Ivor.ViewTerm.Letn'v'ty'sc')=n==n'&&v==v'>&&ty==ty'&&sc==sc'>(==)(Ivor.ViewTerm.Label__ty)(Ivor.ViewTerm.Label__ty')=ty==ty'>(==)(Ivor.ViewTerm.Call__t)(Ivor.ViewTerm.Call__t')=t==t'>(==)(Ivor.ViewTerm.Returnt)(Ivor.ViewTerm.Returnt')=t==t'>(==)Ivor.ViewTerm.StarIvor.ViewTerm.Star=True>(==)PlaceholderPlaceholder=True>(==)(Metavarx)(Metavary)=x==y>(==)(Constantx)(Constanty)=casecastxof>Justx'->x'==y>Nothing->False>(==)(Ivor.ViewTerm.Quotet)(Ivor.ViewTerm.Quotet')=t==t'>(==)(Ivor.ViewTerm.Codet)(Ivor.ViewTerm.Codet')=t==t'>(==)(Ivor.ViewTerm.Evalt)(Ivor.ViewTerm.Evalt')=t==t'>(==)(Ivor.ViewTerm.Escapet)(Ivor.ViewTerm.Escapet')=t==t'>(==)(Annotation_t)(Annotation_t')=t==t'>(==)(Annotation_t)t'=t==t'>(==)t(Annotation_t')=t==t'>(==)__=False>-- | Haskell types which can be used as constants>class(Typeablec,Showc,Eqc)=>ViewConstcwhere>typeof::c->Name>instanceViewConstc=>Constantcwhere>constTypex=TyCon(typeofx)0>-- | Make an application of a function to several arguments>apply::ViewTerm->[ViewTerm]->ViewTerm>applyf[]=f>applyf(x:xs)=Ivor.ViewTerm.apply(Ivor.ViewTerm.Appfx)xs>dataInductive>=Inductive{typecon::Name,>parameters::[(Name,ViewTerm)],>indices::[(Name,ViewTerm)],>contype::ViewTerm,>constructors::[(Name,ViewTerm)]}>instanceForgetViewTermRawwhere>forget(Ivor.ViewTerm.Appfa)=RApp(forgetf)(forgeta)>forget(Ivor.ViewTerm.Lambdavtysc)=RBindv>(BTTCore.Lambda(forgetty))>(forgetsc)>forget(Forallvtysc)=RBindv(BPi(forgetty))(forgetsc)>forget(Ivor.ViewTerm.Letvtyvalsc)=RBindv(B(TTCore.Let(forgetval))>(forgetty))(forgetsc)>forget(Ivor.ViewTerm.Labelnargsty)>=RLabel(forgetty)(RCompn(mapforgetargs))>forget(Ivor.ViewTerm.Callnargsty)>=RCall(RCompn(mapforgetargs))(forgetty)>forget(Ivor.ViewTerm.Returnty)=RReturn(forgetty)>forget(Constantc)=RConstc>forget(Ivor.ViewTerm.Star)=TTCore.RStar>forgetPlaceholder=RInfer>forget(Metavarx)=RMetax>forget(Ivor.ViewTerm.Quotet)=RStage(RQuote(forgett))>forget(Ivor.ViewTerm.Codet)=RStage(RCode(forgett))>forget(Ivor.ViewTerm.Evalt)=RStage(REval(forgett))>forget(Ivor.ViewTerm.Escapet)=RStage(REscape(forgett))>forget(Annotation(FileLocfl)t)=RFileLocfl(forgett)>forgetx=Var(varx)>instanceShowViewTermwhere>show=show.forget>instanceForgetInductiveStringwhere>forget(Inductivenpsindsctycons)=>shown++" "++showbindps++" : "++showbindinds++show(forgetcty)>++" = "++>showconscons>whereshowbind[]="">showbind((x,ty):xs)="("++showx++":"++show(forgetty)++")">++showbindxs>showcons[]="">showcons[x]=showconx>showcons(x:xs)=showconx++" | "++showconsxs>showcon(x,ty)=showx++" : "++show(forgetty)>instanceShowInductivewhere>show=forget>-- |Get a pattern matchable representation of a term.>view::Term->ViewTerm>view(Term(Indtm,_))=vt(Ind(makePstm))>-- |Get a pattern matchable representation of a term's type.>viewType::Term->ViewTerm>viewType(Term(_,Indty))=vt(Ind(makePsty))>vt::IndexedName->ViewTerm>vt(Indtm)=vtaux[]tmwhere>vtauxctxt(Pn)=NameFreen>vtauxctxt(Vi)=NameBound(traceIndexctxti"ViewTerm vt")>vtauxctxt(Con_n_)=NameDataConn>vtauxctxt(TyConn_)=NameTypeConn>vtauxctxt(Elimn)=NameElimOpn>vtauxctxt(TTCore.Appfa)=Ivor.ViewTerm.App(vtauxctxtf)(vtauxctxta)>vtauxctxt(Bindn(BTTCore.Lambdaty)(Scsc))=>Ivor.ViewTerm.Lambdan(vtauxctxtty)(vtaux(n:ctxt)sc)>vtauxctxt(Bindn(BPity)(Scsc))=>Foralln(vtauxctxtty)(vtaux(n:ctxt)sc)>vtauxctxt(Bindn(B(TTCore.Letval)ty)(Scsc))=>Ivor.ViewTerm.Letn(vtauxctxtty)(vtauxctxtval)(vtaux(n:ctxt)sc)>vtauxctxt(Constc)=Constantc>vtauxctxtTTCore.Star=Ivor.ViewTerm.Star>vtauxctxt(TTCore.Labelty(Compnts))=>Ivor.ViewTerm.Labeln(fmap(vtauxctxt)ts)(vtauxctxtty)>vtauxctxt(TTCore.Call(Compnts)ty)=>Ivor.ViewTerm.Calln(fmap(vtauxctxt)ts)(vtauxctxtty)>vtauxctxt(TTCore.Returnty)=Ivor.ViewTerm.Return(vtauxctxtty)>vtauxctxt(Stage(TTCore.Quotetm))>=Ivor.ViewTerm.Quote(vtauxctxttm)>vtauxctxt(Stage(TTCore.Codetm))>=Ivor.ViewTerm.Code(vtauxctxttm)>vtauxctxt(Stage(TTCore.Evaltm_))>=Ivor.ViewTerm.Eval(vtauxctxttm)>vtauxctxt(Stage(TTCore.Escapetm_))>=Ivor.ViewTerm.Escape(vtauxctxttm)>vtauxctxt(Metan_)=Metavarn>vtaux_t=error$"Can't happen vtaux "++debugTTt>-- | Return whether the name occurs free in the term.>freeIn::Name->ViewTerm->Bool>freeInnt=fintwhere>fin(Ivor.ViewTerm.Name_x)|x==n=True>|otherwise=False>fin(Ivor.ViewTerm.Appfa)=finf||fina>fin(Ivor.ViewTerm.Lambdaxtysc)>|x==n=False>|otherwise=finty||finsc>fin(Forallxtysc)|x==n=False>|otherwise=finty||finsc>fin(Ivor.ViewTerm.Letxvtysc)>|x==n=False>|otherwise=finv||finty||finsc>fin(Ivor.ViewTerm.Label__t)=fint>fin(Ivor.ViewTerm.Call__t)=fint>fin(Ivor.ViewTerm.Returnt)=fint>fin(Ivor.ViewTerm.Quotet)=fint>fin(Ivor.ViewTerm.Codet)=fint>fin(Ivor.ViewTerm.Evalt)=fint>fin(Ivor.ViewTerm.Escapet)=fint>fin(Annotation_t)=fint>fin_=False>-- | Return the names occurring free in a term>namesIn::ViewTerm->[Name]>namesInt=nub$fi[]twhere>fins(Ivor.ViewTerm.Name_x)|x`elem`ns=[]>|otherwise=[x]>fins(Ivor.ViewTerm.Appfa)=finsf++finsa>fins(Ivor.ViewTerm.Lambdaxtysc)=fi(x:ns)sc>fins(Forallxtysc)=fi(x:ns)sc>fins(Ivor.ViewTerm.Letxvtysc)=fi(x:ns)sc>fins(Ivor.ViewTerm.Label__t)=finst>fins(Ivor.ViewTerm.Call__t)=finst>fins(Ivor.ViewTerm.Returnt)=finst>fins(Ivor.ViewTerm.Quotet)=finst>fins(Ivor.ViewTerm.Codet)=finst>fins(Ivor.ViewTerm.Evalt)=finst>fins(Ivor.ViewTerm.Escapet)=finst>fins(Annotation_t)=finst>fins_=[]>-- | Return whether a subterm occurs in a (first order) term.>occursIn::ViewTerm->ViewTerm->Bool>occursInnt=fintwhere>fin(Ivor.ViewTerm.Appfa)=finf||fina>fin(Ivor.ViewTerm.Lambdaxtysc)=False-- higher order>fin(Forallxtysc)=False>fin(Ivor.ViewTerm.Letxvtysc)=False>fin(Ivor.ViewTerm.Label__t)=fint>fin(Ivor.ViewTerm.Call__t)=fint>fin(Ivor.ViewTerm.Returnt)=fint>fin(Ivor.ViewTerm.Codet)=fint>fin(Ivor.ViewTerm.Evalt)=fint>fin(Ivor.ViewTerm.Escapet)=fint>fin(Annotation_t)=fint>finx=n==x>-- | Get the function from an application. If no application, returns the>-- entire term.>getApp::ViewTerm->ViewTerm>getApp(Ivor.ViewTerm.Appfa)=getAppf>getApp(Annotation_t)=getAppt>getAppx=x>-- | Get the arguments from a function application.>getFnArgs::ViewTerm->[ViewTerm]>getFnArgs(Ivor.ViewTerm.Appfa)=Ivor.ViewTerm.getFnArgsf++[a]>getFnArgs(Annotation_t)=getFnArgst>getFnArgsx=[]>-- | Get the argument names and types from a function type>getArgTypes::ViewTerm->[(Name,ViewTerm)]>getArgTypes(Ivor.ViewTerm.Forallntysc)=(n,ty):(getArgTypessc)>getArgTypes(Annotation_t)=getArgTypest>getArgTypesx=[]>-- | Get the return type from a function type>getReturnType::ViewTerm->ViewTerm>getReturnType(Ivor.ViewTerm.Forallntysc)=Ivor.ViewTerm.getReturnTypesc>getReturnType(Annotation_t)=Ivor.ViewTerm.getReturnTypet>getReturnTypex=x>dbgshow(UNn)="UN "++shown>dbgshow(MN(n,i))="MN ["++shown++","++showi++"]">-- | Match the second argument against the first, returning a list of>-- the names in the first paired with their matches in the second. Returns>-- Nothing if there is a match failure. There is no searching under binders.>matchMeta::ViewTerm->ViewTerm->Maybe[(Name,ViewTerm)]>matchMetat1t2=doacc<-m't1t2[]>checkDupsacc[]where>m'(Metavarn)tacc=return((n,t):acc)>m'Placeholdertacc=returnacc>m'(Ivor.ViewTerm.Appfa)(Ivor.ViewTerm.Appf'a')acc>=doacc'<-m'ff'acc>m'aa'acc'>m'(Annotation_t)t'acc=m'tt'acc>m't(Annotation_t')acc=m'tt'acc>m'(Name_x)(Name_y)acc|x==y=returnacc>m'xyacc|x==y=returnacc>|otherwise=fail$"Mismatch "++showx++" and "++showy>checkDups[]acc=returnacc>checkDups((x,t):xs)acc>=caselookupxxsof>Justt'->ift==t'thencheckDupsxsacc>elsefail$"Mismatch on "++showx>Nothing->checkDupsxs((x,t):acc)>replaceMeta::[(Name,ViewTerm)]->ViewTerm->ViewTerm>replaceMetams(Metavarn)=caselookupnmsof>Justt->t>_->Metavarn>replaceMetams(Ivor.ViewTerm.Appfa)>=Ivor.ViewTerm.App(replaceMetamsf)(replaceMetamsa)>replaceMetams(Annotationat)=Annotationa(replaceMetamst)>replaceMetamsx=x>-- |Substitute a name n with a value v in a term f >subst::Name->ViewTerm->ViewTerm->ViewTerm>substnvnm@(Name_p)|p==n=v>|otherwise=nm>substnv(Ivor.ViewTerm.Appfa)>=Ivor.ViewTerm.App(substnvf)(substnva)>substnv(Ivor.ViewTerm.Lambdanntysc)>=Ivor.ViewTerm.Lambdann(substnvty)$>if(n==nn)thenscelsesubstnvsc>substnv(Forallnntysc)>=Forallnn(substnvty)$>if(n==nn)thenscelsesubstnvsc>substnv(Ivor.ViewTerm.Letnntyvvsc)>=Ivor.ViewTerm.Letnn(substnvty)(substnvvv)$>if(n==nn)thenscelsesubstnvsc>substnv(Ivor.ViewTerm.Labelfnargsty)>=Ivor.ViewTerm.Labelfn(map(substnv)args)(substnvty)>substnv(Ivor.ViewTerm.Callfnargsty)>=Ivor.ViewTerm.Callfn(map(substnv)args)(substnvty)>substnv(Ivor.ViewTerm.Returnr)>=Ivor.ViewTerm.Return(substnvr)>substnv(Ivor.ViewTerm.Quoter)>=Ivor.ViewTerm.Quote(substnvr)>substnv(Ivor.ViewTerm.Coder)>=Ivor.ViewTerm.Code(substnvr)>substnv(Ivor.ViewTerm.Evalr)>=Ivor.ViewTerm.Eval(substnvr)>substnv(Ivor.ViewTerm.Escaper)>=Ivor.ViewTerm.Escape(substnvr)>substnv(Annotationat)=Annotationa(substnvt)>substnvt=t>-- |Transform a term according to a rewrite rule.>transform::ViewTerm-- ^ Left hand side, with metavariables>->ViewTerm-- ^ Right hand side, with metavariables>->ViewTerm-- ^ Term to rewrite>->ViewTerm>transformlhsrhsterm=tr'termwhere>tr'(Ivor.ViewTerm.Appfa)>=doTr$Ivor.ViewTerm.App(tr'f)(tr'a)>tr'(Ivor.ViewTerm.Lambdavtsc)>=doTr$Ivor.ViewTerm.Lambdav(tr't)(tr'sc)>tr'(Ivor.ViewTerm.Forallvtsc)>=doTr$Ivor.ViewTerm.Forallv(tr't)(tr'sc)>tr'(Ivor.ViewTerm.Letvtvalsc)>=doTr$Ivor.ViewTerm.Letv(tr't)(tr'val)(tr'sc)>tr'(Annotationat)=doTr$Annotationa(tr't)>tr'x=doTrx>doTrx=casematchMetalhsxof>Justvars->replaceMetavarsrhs>Nothing->x>instanceBinaryNamewhere>put(UNs)=doput(0::Word8);puts>put(MNs)=doput(1::Word8);puts>get=dotag<-getWord8>casetagof>0->liftMUNget>1->liftMMNget>instanceBinaryNameTypewhere>putx=put(fromEnumx)>get=dot<-get>return(toEnumt)>instanceBinaryAnnotwhere>put(FileLocpi)=doputp;puti>get=dop<-get>i<-get>return(FileLocpi)