{-# LANGUAGE UndecidableInstances, FunctionalDependencies, FlexibleContexts #-}{-# LANGUAGE TypeSynonymInstances, MultiParamTypeClasses #-}{-# LANGUAGE PatternGuards, FlexibleInstances, CPP #-}-- |-- Module : Scion.Inspect.Search-- Copyright : (c) Thomas Schilling 2008-- License : BSD-style---- Maintainer : nominolo@gmail.com-- Stability : experimental-- Portability : portable---- Find things in a syntax tree.--moduleScion.Inspect.Find(findHsThing,SearchResult(..),SearchResults,PosTree(..),PosForest,deepestLeaf,pathToDeepest,surrounds,overlaps#ifdef DEBUG,prop_invCmpOverlap#endif)whereimportScion.Utils()importGHCimportBasicTypes(IPName(..))importBagimportVar(varName)importOutputableimportData.Monoid(mempty,mappend,mconcat)importData.FoldableasF(toList,maximumBy)importData.Ord(comparing)importqualifiedData.SetasS------------------------------------------------------------------------------dataPosTreea=Node{val::a,children::PosForesta}deriving(Eq,Ord)typePosForesta=S.Set(PosTreea)-- | Lookup all the things in a certain region.findHsThing::Searchida=>(SrcSpan->Bool)->a->SearchResultsidfindHsThingpa=searchpnoSrcSpanadeepestLeaf::Orda=>PosTreea->adeepestLeaft=snd$go(0::Int)twheregon(Nodexxs)|S.nullxs=(n,x)|otherwise=maximumBy(comparingfst)(S.map(go(n+1))xs)-- | Returns the deepest leaf, together with the path to this leaf. For-- example, for the following tree with root @A@:-- @-- A -+- B --- C-- '- D --- E --- F-- @-- this function will return:-- @-- (F, [E, D, A])-- @-- If @F@ were missing the result is either @(C, [B,A])@ or @(E, [D,A])@.-- pathToDeepest::Orda=>PosForesta->Maybe(a,[a])pathToDeepestforest|S.nullforest=Nothing|otherwise=Just$ptl3$go_many(0::Int)[]forestwheregonpath(Nodexxs)|S.nullxs=(n,x,path)|otherwise=go_many(n+1)(x:path)xsgo_manynpathxs=maximumBy(comparingfst3)(S.map(gonpath)xs)fst3(x,_,_)=xptl3(_,x,y)=(x,y)dataSearchResultid=FoundBindSrcSpan(HsBindid)|FoundPatSrcSpan(Patid)|FoundTypeSrcSpan(HsTypeid)|FoundExprSrcSpan(HsExprid)|FoundStmtSrcSpan(Stmtid)|FoundIdId|FoundNameName|FoundConSrcSpanDataCon|FoundLitSrcSpanHsLitresLoc::SearchResultid->SrcSpanresLoc(FoundIdi)=nameSrcSpan(varNamei)resLoc(FoundNamen)=nameSrcSpannresLoc(FoundBinds_)=sresLoc(FoundPats_)=sresLoc(FoundTypes_)=sresLoc(FoundExprs_)=sresLoc(FoundStmts_)=sresLoc(FoundCons_)=sresLoc(FoundLits_)=sinstanceEq(SearchResultid)wherea==b=resLoca==resLocb-- TODO: sufficient?instanceOrd(SearchResultid)wherecompareab=compare(resLoca)(resLocb)typeSearchResultsid=PosForest(SearchResultid)-- | Given two good SrcSpans (see 'SrcLoc.isGoodSrcSpan'), returns 'EQ' if the-- spans overlap or, if not, the relative ordering of both.cmpOverlap::SrcSpan->SrcSpan->OrderingcmpOverlapsp1sp2|not(isGoodSrcSpansp1)=LT|not(isGoodSrcSpansp2)=GT|end1<start2=LT|end2<start1=GT|otherwise=EQwhere-- At this point we assume that both spans are good. We also ignore the-- file names since faststrings seem to be rather unreliable.start1=(srcSpanStartLinesp1,srcSpanStartColsp1)end1=(srcSpanEndLinesp1,srcSpanEndColsp1)start2=(srcSpanStartLinesp2,srcSpanStartColsp2)end2=(srcSpanEndLinesp2,srcSpanEndColsp2)surrounds::SrcSpan->SrcSpan->Boolsurroundsouterinner=start1<=start2&&end2<=end1wherestart1=srcSpanStartouterend1=srcSpanEndouterstart2=srcSpanStartinnerend2=srcSpanEndinneroverlaps::SrcSpan->SrcSpan->Booloverlapssp1sp2=cmpOverlapsp1sp2==EQ#ifdef DEBUGprop_invCmpOverlap::SrcSpan->SrcSpan->Boolprop_invCmpOverlaps1s2=casecmpOverlaps1s2ofLT->cmpOverlaps2s1==GTEQ->cmpOverlaps2s1==EQGT->cmpOverlaps2s1==LT-- prop_sane : if overlap -> there is some point which is in both spans#endif------------------------------------------------------------------------------instance(OutputableBndrid,Outputableid)=>Outputable(SearchResultid)whereppr(FoundBindsb)=text"bind:"<+>pprs$$nest4(pprb)ppr(FoundPatsb)=text"pat: "<+>pprs$$nest4(pprb)ppr(FoundTypest)=text"type:"<+>pprs$$nest4(pprt)ppr(FoundExprse)=text"expr:"<+>pprs$$nest4(ppre)ppr(FoundStmtst)=text"stmt:"<+>pprs$$nest4(pprt)ppr(FoundIdi)=text"id: "<+>pprippr(FoundNamen)=text"name:"<+>pprnppr(FoundConsc)=text"con: "<+>pprs$$nest4(pprc)ppr(FoundLitsl)=text"lit: "<+>pprs$$nest4(pprl)instanceOutputablea=>Outputable(PosTreea)whereppr(Nodevcs)=pprv$$nest2(vcat(mapppr(S.toListcs)))classSearchida|a->idwheresearch::(SrcSpan->Bool)->SrcSpan->a->SearchResultsidonly::SearchResultid->SearchResultsidonlyr=S.singleton(NoderS.empty)above::SearchResultid->SearchResultsid->SearchResultsidaboverrest=S.singleton(Noderrest)instanceSearchIdIdwheresearch__i=only(FoundIdi)instanceSearchNameNamewheresearch__i=only(FoundNamei)instanceSearchidDataConwheresearch_sd=only(FoundConsd)instanceSearchidHsLitwheresearch_sl=only(FoundLitsl)instanceSearchidid=>Searchid(IPNameid)wheresearchps(IPNamei)=searchpsiinstanceSearchida=>Searchid(Locateda)wheresearchp_(Lsa)|ps=searchpsa|otherwise=memptyinstanceSearchida=>Searchid(Baga)wheresearchpsbs=mconcat$fmap(searchps)(F.toListbs)instanceSearchida=>Searchid[a]wheresearchpsbs=mconcat$fmap(searchps)bsinstanceSearchida=>Searchid(Maybea)wheresearch__Nothing=memptysearchps(Justa)=searchpsainstance(Searchidid)=>Searchid(HsGroupid)wheresearchpsgrp=searchps(hs_valdsgrp)-- TODOinstance(Searchidid)=>Searchid(HsBindLRidid)wheresearchpsb=FoundBindsb`above`search_insidewheresearch_inside=casebofFunBind{fun_id=i,fun_matches=ms}->searchpsi`mappend`searchpsmsAbsBinds{abs_binds=bs}->searchpsbsPatBind{pat_lhs=lhs,pat_rhs=rhs}->searchpslhs`mappend`searchpsrhs_->memptyinstance(Searchidid)=>Searchid(MatchGroupid)wheresearchps(MatchGroupms_)=searchpsmsinstance(Searchidid)=>Searchid(Matchid)wheresearchps(Matchpatstysigrhss)=searchpspats`mappend`searchpstysig`mappend`searchpsrhssinstance(Searchidid)=>Searchid(Patid)wheresearchpspat0=FoundPatspat0`above`search_insidewheresearch_inside=casepat0ofVarPati->searchpsiVarPatOuti_->searchpsiLazyPatpat->searchpspatAsPatipat->searchpsi`mappend`searchpspatParPatpat->searchpspatBangPatpat->searchpspatListPatps_->searchpspsTuplePatps__->searchpspsPArrPatps_->searchpspsConPatInid->searchpsi`mappend`searchpsdConPatOutc___d_->searchpsc`mappend`searchpsdViewPatept_->searchpse`mappend`searchpsptTypePatt->searchpstSigPatInptt->searchpspt`mappend`searchpstSigPatOutpt_->searchpsptNPlusKPatn___->searchpsn_->mempty-- type HsConPatDetails id = HsConDetails (LPat id) (HsRecFields id (LPat id))instance(Searchidarg,Searchidrec)=>Searchid(HsConDetailsargrec)wheresearchps(PrefixConargs)=searchpsargssearchps(RecConrec)=searchpsrecsearchps(InfixCona1a2)=searchpsa1`mappend`searchpsa2instance(Searchidid)=>Searchid(HsTypeid)wheresearch_st=only(FoundTypest)instance(Searchidid)=>Searchid(GRHSsid)wheresearchps(GRHSsrhsslocal_binds)=searchpsrhss`mappend`searchpslocal_bindsinstance(Searchidid)=>Searchid(GRHSid)wheresearchps(GRHS_guardsrhs)=-- guards look like statements, but we should probably treat them-- differentlysearchpsrhsinstance(Searchidid)=>Searchid(HsExprid)wheresearchpse0=FoundExprse0`above`search_insidewheresearch_inside=casee0ofHsVari->searchpsiHsIPVari->searchpsiHsLitl->searchpslExprWithTySigOute_t->searchpse--`mappend` search p s tHsBracketOut_b_->mempty-- search p s bHsLammg->searchpsmgHsApplr->searchpsl`mappend`searchpsrOpApplo_r->searchpsl`mappend`searchpso`mappend`searchpsrNegAppen->searchpse`mappend`searchpsnHsPare->searchpseSectionLeo->searchpse`mappend`searchpsoSectionRoe->searchpso`mappend`searchpseHsCaseemg->searchpse`mappend`searchpsmgHsIfcte->searchpsc`mappend`searchpst`mappend`searchpseHsLetbse->searchpsbs`mappend`searchpseHsDo_sse_->searchpsss`mappend`searchpseExplicitList_es->searchpsesExplicitPArr_es->searchpsesExplicitTuplees_->searchpsesRecordCon__bs->searchpsbsRecordUpdesbs___->searchpses`mappend`searchpsbsExprWithTySiget->searchpse`mappend`searchpst--ExprWithTySigOut e t -> memptyArithSeq_i->searchpsiPArrSeq_i->searchpsiHsSCC_e->searchpseHsCoreAnn_e->searchpseHsBracketb->searchpsb--HsBracketOut b _ -> search p s b --HsSpliceEsp->searchpsspHsQuasiQuoteE_->memptyHsProcpatct->searchpspat`mappend`searchpsctHsArrAppfarg___->searchpsf`mappend`searchpsargHsArrForme_cmds->searchpse`mappend`searchpscmdsHsTick__e->searchpseHsBinTick__e->searchpseHsTickPragma_e->searchpseHsWrap_e->searchpse_->memptyinstance(Searchidid)=>Searchid(HsLocalBindsLRidid)wheresearchps(HsValBindsval_binds)=searchpsval_bindssearch___=memptyinstance(Searchidid)=>Searchid(HsValBindsLRidid)wheresearchps(ValBindsOutrec_binds_)=mconcat$fmap(searchps.snd)rec_bindssearch___=memptyinstance(Searchidid)=>Searchid(HsCmdTopid)wheresearchps(HsCmdTopc___)=searchpscinstance(Searchidid)=>Searchid(StmtLRidid)wheresearchpsst|RecStmt_____<-st=search_inside-- see Note [SearchRecStmt]|otherwise=FoundStmtsst`above`search_insidewheresearch_inside=casestofBindStmtpate__->searchpspat`mappend`searchpseExprStmte__->searchpseLetStmtbs->searchpsbsParStmtss->searchps(concatMapfstss)TransformStmt(ss,_)fe->searchpsss`mappend`searchpsf`mappend`searchpseGroupStmt(ss,_)g->searchpsss`mappend`searchpsgRecStmtss____->searchpsss---- Note [SearchRecStmt]-- ------------------------ We only return children of a RecStmt but not the RecStmt itself, even-- though a RecStmt may occur in the source code (under very rare-- circumstances). The reasons are:---- * We have no way of knowing whether the RecStmt actually occured in the-- source code. We could add a flag in GHC, but its probably not-- worthwhile due to the other reason.---- * GHC may move things out of the recursive group if it detects that these-- things are in fact not recursive at all. Source locations are-- preserved, so this is fine.--instance(Searchidid)=>Searchid(GroupByClauseid)wheresearchps(GroupByNothingf)=searchpsfsearchps(GroupBySomethingusing_fe)=either(searchps)(constmempty)using_f`mappend`searchpseinstance(Searchidid)=>Searchid(ArithSeqInfoid)wheresearchps(Frome)=searchpsesearchps(FromThene1e2)=searchpse1`mappend`searchpse2searchps(FromToe1e2)=searchpse1`mappend`searchpse2searchps(FromThenToe1e2e3)=searchpse1`mappend`searchpse2`mappend`searchpse3-- type HsRecordBinds id = HsRecFields id (LHsExpr id)instanceSearchide=>Searchid(HsRecFieldside)wheresearchps(HsRecFieldsflds_)=searchpsfldsinstanceSearchide=>Searchid(HsRecFieldide)wheresearchps(HsRecField_lida_)=searchpsainstance(Searchidid)=>Searchid(HsBracketid)wheresearchps(ExpBre)=searchpsesearchps(PatBrq)=searchpsqsearchps(DecBrg)=searchpsgsearchps(TypBrt)=searchpstsearch__(VarBr_)=memptyinstance(Searchidid)=>Searchid(HsSpliceid)wheresearchps(HsSplice_e)=searchpse