{-# LANGUAGE CPP #-} -- ---------------------------------------------------------------------------- -- | -- Module : ExprSearch -- Author : Simon Marlow -- Copyright : (c) Microsoft Corporation, All Rights Reserved -- -- Searching for names in abstract syntax -- -- ---------------------------------------------------------------------------- module Shim.ExprSearch ( findExprInCheckedModule, FindResult(..) ) where import GHC import Id import HsSyn import Module import Bag import SrcLoc import DataCon ( dataConWrapId ) import Foreign import FiniteMap infix 1 `implies` -- ----------------------------------------------------------------------------- -- Expression searching -- Here we search the abstract syntax tree for the minimal expression -- enclosing the selected span. For now, we only consider a point -- span, so the minimal expression will always be a variable or -- literal (keywords etc. are ignored - we just return NotFound). data FindResult = FoundId Id | FoundName Name | FoundLit HsLit | FoundModule ModuleName | NotFound findExprInCheckedModule :: Int -> Int -> TypecheckedModule -> FindResult findExprInCheckedModule line col mdl = let hsSource = parsedSource mdl mb_rnSource = renamedSource mdl mb_tcSource = Just $ typecheckedSource mdl in case doSearch searchLBinds FoundId mb_tcSource of NotFound -> case doSearch searchRenamedSource FoundName mb_rnSource of NotFound -> doSearchModule hsSource res -> res res -> res where doSearch f ret (Just x) = runSearch line col ret (f x) doSearch f ret Nothing = NotFound doSearchModule (L span (HsModule _ _ decls _ _ _ _)) = runSearch line col undefined (searchList searchLImportDecl decls) searchRenamedSource (group, _, _, _, _) = searchGroup group -- ----------------------------------------------------------------------------- -- Import declarations searching -- ----------------------------------------------------------------------------- -- Utils used in expr searching searchList :: (a -> Search b) -> [a] -> Search b searchList f = foldr (orSearch . f) failSearch searchBag :: (a -> Search b) -> Bag a -> Search b searchBag f bag = searchList f (bagToList bag) searchMaybe :: (a -> Search b) -> Maybe a -> Search b searchMaybe f Nothing = failSearch searchMaybe f (Just a) = f a lsearch :: (a -> Search b) -> Located a -> Search b lsearch f (L span a) = contSpan span (f a) lsearch' :: (a -> Search b) -> Located a -> Search b lsearch' f (L span a) = contSpan span (f a) -- ----------------------------------------------------------------------------- -- Binds searchLBinds = searchBag searchLBind searchLBind (L _ (AbsBinds _ _ exports bs)) = extendIdMap pairs $ searchLBinds bs where pairs = [(mono,poly) | (_tvs,poly,mono,_) <- exports] searchLBind (L span bind) = contSpan span $ searchBind bind searchBind (FunBind (L idspan id) _ lmatches _ _ _) = checkId idspan id `orSearch` searchMatchGroup lmatches searchBind (PatBind pat grhss _ _) = searchLPat pat `orSearch` searchGRHSs grhss searchBind _ = failSearch searchLocalBinds (HsValBinds vbinds) = searchValBinds vbinds searchLocalBinds (HsIPBinds (IPBinds lipbinds binds)) = searchList searchLIPBind lipbinds `orSearch` searchLBinds binds searchLocalBinds EmptyLocalBinds = failSearch searchValBinds (ValBindsIn binds sigs) = searchLBinds binds `orSearch` searchList searchLSig sigs searchValBinds (ValBindsOut binds sigs) = foldr (\(_,binds) cont -> searchLBinds binds `orSearch` cont) failSearch binds `orSearch` Search (\line col idmap ret -> runSearch line col FoundName (searchList searchLSig sigs)) searchLIPBind = lsearch searchIPBind searchIPBind (IPBind _ipname e) = searchLExpr e -- ----------------------------------------------------------------------------- -- Patterns searchLPat (L span (VarPat id)) = checkId span id searchLPat (L span (LitPat lit)) = checkLiteral span lit searchLPat (L span (NPat lit _ _)) = checkLiteral span (over_lit_lit lit) where over_lit_lit :: HsOverLit id -> HsLit over_lit_lit (OverLit (HsIntegral i) _ _ _) = HsIntPrim i over_lit_lit (OverLit (HsFractional f) _ _ _) = HsFloatPrim f over_lit_lit (OverLit (HsIsString s) _ _ _) = HsStringPrim s searchLPat lpat = lsearch searchPat lpat searchPat pat = case pat of LazyPat p -> searchLPat p AsPat lid p -> searchLId lid `orSearch` searchLPat p ParPat p -> searchLPat p ListPat ps _ -> searchList searchLPat ps TuplePat ps _ _ -> searchList searchLPat ps PArrPat ps _ -> searchList searchLPat ps ConPatOut (L span con) _ _ _ details _ -> inSpan span (Search $ \line col idmap ret -> FoundId (dataConWrapId con)) `orSearch` searchConDetails searchLPat details NPlusKPat lid int _ _ -> searchLId lid -- ToDo: the int should be located TypePat t -> searchLType t SigPatOut p _ -> searchLPat p -- ToDo: the type should be located _other -> failSearch searchConDetails search details = case details of PrefixCon ps -> searchList search ps RecCon (HsRecFields fields dotdot) -> searchList rec fields where rec (HsRecField lid p _) = searchLId lid `orSearch` search p InfixCon p1 p2 -> search p1 `orSearch` search p2 searchConDeclDetails search (PrefixCon ps) = searchList search ps searchConDeclDetails search (InfixCon p1 p2) = search p1 `orSearch` search p2 searchConDeclDetails search (RecCon fields) = searchList rec fields where rec (ConDeclField ln ty _) = searchLId ln `orSearch` search ty -- ----------------------------------------------------------------------------- -- Matches searchMatchGroup (MatchGroup lmatches _) = searchLMatches lmatches searchLMatches = searchList searchLMatch searchLMatch lmatch@(L span _) = lsearch' searchMatch lmatch searchMatch (Match pats result_ty grhss) = searchList searchLPat pats `orSearch` searchMaybe searchLType result_ty `orSearch` searchGRHSs grhss searchGRHSs (GRHSs lgrhs bindgroups) = searchList searchLGRHS lgrhs `orSearch` searchLocalBinds bindgroups searchLGRHS lgrhs@(L span _) = lsearch' searchGRHS lgrhs searchGRHS (GRHS stmts expr) = searchLStmts stmts `orSearch` searchLExpr expr -- ----------------------------------------------------------------------------- -- Statements searchLStmts = searchList searchLStmt searchLStmt = lsearch searchStmt searchStmt (BindStmt pat lexpr _ _) = searchLPat pat `orSearch` searchLExpr lexpr searchStmt (LetStmt bindgroups) = searchLocalBinds bindgroups searchStmt (ExprStmt lexpr _ _) = searchLExpr lexpr searchStmt (ParStmt pars) = searchList (searchList searchLStmt . fst) pars searchStmt (RecStmt lstmts _ _ exprs _) = searchLStmts lstmts -- ----------------------------------------------------------------------------- -- Expressions searchLId (L span id) = checkId span id searchLExprs = searchList searchLExpr searchLExpr (L span (HsLit lit)) = checkLiteral span lit searchLExpr (L span (HsVar id)) = checkId span id searchLExpr (L span (HsWrap _ e)) = checkId span id where id = getCornerId e searchLExpr = lsearch searchExpr -- The typechecker likes to expand identifiers with type applications -- and dictionary applications, but it doesn't propagate the srcloc -- info down. So we spot those expanded expressions here: getCornerIdL (L _ e) = getCornerId e getCornerId (HsVar id) = id getCornerId (HsWrap _ e) = getCornerId e searchExpr e = case e of HsLam lmatch -> searchMatchGroup lmatch HsApp e1 e2 -> searchLExpr e1 `orSearch` searchLExpr e2 OpApp e1 op _fix e2 -> searchLExpr e1 `orSearch` searchLExpr op `orSearch` searchLExpr e2 NegApp e _ -> searchLExpr e HsPar e -> searchLExpr e SectionL e op -> searchLExpr e `orSearch` searchLExpr op SectionR op e -> searchLExpr op `orSearch` searchLExpr e HsCase e lmatches -> searchLExpr e `orSearch` searchMatchGroup lmatches HsIf e1 e2 e3 -> searchLExpr e1 `orSearch` searchLExpr e2 `orSearch` searchLExpr e3 HsLet bindgroups e -> searchLocalBinds bindgroups `orSearch` searchLExpr e HsDo _ lstmts e _ -> searchLStmts lstmts `orSearch` searchLExpr e ExplicitList _ lexprs -> searchLExprs lexprs ExplicitPArr _ lexprs -> searchLExprs lexprs ExplicitTuple lexprs _ -> searchLExprs lexprs RecordCon lid _ recbinds -> searchLId lid `orSearch` searchRecBinds recbinds RecordUpd e recbinds _ _ _ -> searchLExpr e `orSearch` searchRecBinds recbinds ExprWithTySig e ty -> searchLExpr e `orSearch` searchLType ty ArithSeq e seqinfo -> searchSeqInfo seqinfo PArrSeq e seqinfo -> searchSeqInfo seqinfo HsSCC _ e -> searchLExpr e HsCoreAnn _ e -> searchLExpr e HsWrap _ e -> searchExpr e _ -> failSearch -- nothing else contains any names. -- Implicit parameters: we can't jump to the decl, -- because they are dynamically scoped! searchSeqInfo (From e1) = searchLExpr e1 searchSeqInfo (FromThen e1 e2) = searchLExpr e1 `orSearch` searchLExpr e2 searchSeqInfo (FromTo e1 e2) = searchLExpr e1 `orSearch` searchLExpr e2 searchSeqInfo (FromThenTo e1 e2 e3) = searchLExpr e1 `orSearch` searchLExpr e2 `orSearch` searchLExpr e3 searchRecBinds :: Ord b => HsRecordBinds b -> Search b searchRecBinds (HsRecFields fields dotdot) = searchList searchRecBind fields where searchRecBind (HsRecField (L span field) expr _) = checkId span field `orSearch` searchLExpr expr -- ---------------------------------------------------------------------------- -- Sigs searchLSig = lsearch searchSig searchSig (TypeSig lid tp) = searchLId lid `orSearch` searchLType tp searchSig (SpecSig lid tp _) = searchLId lid `orSearch` searchLType tp searchSig (InlineSig lid _) = searchLId lid searchSig (SpecInstSig tp) = searchLType tp searchSig (FixSig fix) = searchFixitySig fix -- ---------------------------------------------------------------------------- -- FixitySig searchLFixitySig = lsearch searchFixitySig searchFixitySig (FixitySig lid _) = searchLId lid -- ---------------------------------------------------------------------------- -- Types searchLTypes = searchList searchLType searchLType = lsearch searchType searchType (HsForAllTy _ _ ctxt tp) = searchLContext ctxt `orSearch` searchLType tp searchType (HsTyVar id) = Search (\line col idmap ret -> ret id) searchType (HsBangTy _ tp) = searchLType tp searchType (HsAppTy tp1 tp2) = searchLType tp1 `orSearch` searchLType tp2 searchType (HsFunTy tp1 tp2) = searchLType tp1 `orSearch` searchLType tp2 searchType (HsListTy tp) = searchLType tp searchType (HsPArrTy tp) = searchLType tp searchType (HsTupleTy _ tps) = searchLTypes tps searchType (HsOpTy tpl lid tpr) = searchLType tpl `orSearch` searchLId lid `orSearch` searchLType tpr searchType (HsParTy tp) = searchLType tp searchType (HsPredTy pred) = searchPred pred searchType _ = failSearch -- ---------------------------------------------------------------------------- -- Context searchLContext = lsearch searchContext searchContext = searchList searchLPred -- ---------------------------------------------------------------------------- -- Pred searchLPred (L span (HsClassP id tps)) = checkId span id `orSearch` searchLTypes tps searchLPred lpred = lsearch searchPred lpred searchPred (HsClassP _ tps) = searchLTypes tps searchPred (HsIParam _ tp) = searchLType tp -- ---------------------------------------------------------------------------- -- TyClDecl searchLTyClDecl = lsearch searchTyClDecl searchTyClDecl (ForeignType lid _ _) = searchLId lid searchTyClDecl td@(TyData {}) = searchLContext (tcdCtxt td) `orSearch` searchLId (tcdLName td) `orSearch` searchList searchLConDecl (tcdCons td) `orSearch` searchMaybe searchLTypes (tcdDerivs td) searchTyClDecl ts@(TySynonym {}) = searchLId (tcdLName ts) `orSearch` searchLType (tcdSynRhs ts) searchTyClDecl cd@(ClassDecl {}) = searchLContext (tcdCtxt cd) `orSearch` searchLId (tcdLName cd) `orSearch` searchList searchLSig (tcdSigs cd) `orSearch` searchLBinds (tcdMeths cd) -- ---------------------------------------------------------------------------- -- ConDecl searchLConDecl = lsearch searchConDecl searchConDecl (ConDecl lid _ lbndrs lctxt details res _) = searchLId lid `orSearch` searchList searchLBndr lbndrs `orSearch` searchLContext lctxt `orSearch` searchConDeclDetails searchLType details `orSearch` searchResType res where searchResType ResTyH98 = failSearch searchResType (ResTyGADT ltype) = searchLType ltype searchLBndr (L span (UserTyVar id )) = checkId span id searchLBndr (L span (KindedTyVar id _)) = checkId span id -- ---------------------------------------------------------------------------- -- InstDecl searchLInstDecl = lsearch searchInstDecl searchInstDecl (InstDecl ltp lbinds lsigs _) = searchLType ltp `orSearch` searchLBinds lbinds `orSearch` searchList searchLSig lsigs -- ---------------------------------------------------------------------------- -- DefaultDecl searchLDefaultDecl = lsearch searchDefaultDecl searchDefaultDecl (DefaultDecl ltps) = searchLTypes ltps -- ---------------------------------------------------------------------------- -- ForeignDecl searchLForeignDecl = lsearch searchForeignDecl searchForeignDecl (ForeignImport lid ltp _) = searchLId lid `orSearch` searchLType ltp searchForeignDecl (ForeignExport lid ltp _) = searchLId lid `orSearch` searchLType ltp -- ---------------------------------------------------------------------------- -- RuleDecl searchLRuleDecl = lsearch searchRuleDecl searchRuleDecl (HsRule _ _ bndrs lexpr1 _ lexpr2 _) = searchList searchRuleBndr bndrs `orSearch` searchLExpr lexpr1 `orSearch` searchLExpr lexpr2 searchRuleBndr (RuleBndr lid) = searchLId lid searchRuleBndr (RuleBndrSig lid ltp) = searchLId lid `orSearch` searchLType ltp -- ---------------------------------------------------------------------------- -- Group searchGroup g@(HsGroup {}) = searchValBinds (hs_valds g) `orSearch` searchList searchLTyClDecl (hs_tyclds g) `orSearch` searchList searchLInstDecl (hs_instds g) `orSearch` searchList searchLFixitySig (hs_fixds g) `orSearch` searchList searchLDefaultDecl (hs_defds g) `orSearch` searchList searchLForeignDecl (hs_fords g) `orSearch` searchList searchLRuleDecl (hs_ruleds g) -- ---------------------------------------------------------------------------- -- ImportDecl searchLImportDecl = lsearch searchImportDecl searchImportDecl (ImportDecl (L span modl) _ _ _ _ _) = inSpan span (Search $ \_ _ _ _ -> FoundModule modl) -- ---------------------------------------------------------------------------- -- Utils -- A search abstraction. It's not a monad, because the main combining -- operation is orSearch below, which doesn't have the same type as bind. newtype Search a = Search { unSearch :: Int -> Int -> FiniteMap a a -> (a -> FindResult) -> FindResult } failSearch = Search $ \line col idmap ret -> NotFound orSearch :: Search a -> Search a -> Search a Search s1 `orSearch` Search s2 = Search $ \line col idmap ret -> case s1 line col idmap ret of NotFound -> s2 line col idmap ret result -> result runSearch :: Int -> Int -> (a -> FindResult) -> Search a -> FindResult runSearch line col ret (Search m) = m line col emptyFM ret extendIdMap :: Ord a => [(a,a)] -> Search a -> Search a extendIdMap pairs s = Search $ \line col idmap ret -> unSearch s line col (addListToFM idmap pairs) ret -- we accept the column after the span too: if you have the cursor at -- the position directly after an identifier, then we'll count that as -- part of the identifier too. If you have two adjacent identifiers -- (eg. f$), then you could get either. inSpan :: SrcSpan -> Search a -> Search a inSpan span inside = Search check where check line col idmap ret | not (isGoodSrcSpan span) = NotFound | line < sline = NotFound | line > eline = NotFound | (line == sline `implies` col >= scol) && (line == eline `implies` col <= ecol) = unSearch inside line col idmap ret | otherwise = NotFound where sloc = srcSpanStart span sline = srcLocLine sloc scol = srcLocCol sloc eloc = srcSpanEnd span eline = srcLocLine eloc ecol = srcLocCol eloc False `implies` b = True True `implies` b = b -- For checking whether we should descend into a subexpression, check whether -- the location we're after lies within the span of the expression. If -- the expression has no good src loc info, then conservatively descend anyway. contSpan :: SrcSpan -> Search a -> Search a contSpan span cont | not (isGoodSrcSpan span) = cont | otherwise = inSpan span cont -- For checking whether we've found the right token. In this case, if the -- token has no src loc info, we ignore it (different to contSpan) checkLiteral :: SrcSpan -> HsLit -> Search a checkLiteral span yes = inSpan span (Search $ \line col idmap ret -> FoundLit yes) checkId :: Ord a => SrcSpan -> a -> Search a checkId span id = inSpan span mapped where mapped = Search $ \line col idmap ret -> case lookupFM idmap id of Nothing -> ret id Just id' -> ret id'