{-# OPTIONS -Wall #-} module Language.Haskell.HBB.OccurrencesOf ( occurrencesOf, occurrencesOfM, showOccurrencesOfResult, BufLoc(..), BufSpan(..) ) where import Language.Haskell.HBB.Internal.GHCHighlevel import Language.Haskell.HBB.Internal.SrcSpan import Language.Haskell.HBB.Internal.Lexer import Language.Haskell.HBB.Internal.GHC import Language.Haskell.HBB.Internal.AST import System.FilePath (normalise) import Control.Monad (foldM) import Data.Generics import FastString (unpackFS,fsLit) import System.IO (hPutStrLn,stderr) import GHC.Paths (libdir) import Data.List (union) import GhcMonad (liftIO) import HsBinds import SrcLoc import Name import GHC occurrencesOf :: [String] -> FilePath -> BufLoc -> [FilePath] -> IO [(FilePath,BufSpan)] occurrencesOf ghcOptions filename reqLoc otherFiles = runGhcWithCmdLineFlags ghcOptions (Just libdir) $ occurrencesOfM filename reqLoc otherFiles occurrencesOfM :: GhcMonad m => FilePath -> BufLoc -> [FilePath] -> m [(FilePath,BufSpan)] occurrencesOfM occFile' loc otherFiles' = do -- We normalize the filenames to be able to use 'union' from -- 'Data.List' to merge them. let occFile = normalise occFile' otherFiles = map normalise otherFiles' resLocs <- do updateDynFlagsToSuppressFileOutput res <- getVariableIdUsingLexerAt (occFile,loc) IncludeQualifiedVars let spanIdentifiedByLexer = case res of Left VarNotFound -> error "It seems that there is no variable at this point?!" Left LexingFailed -> error "Lexing failed. The source code seems to contain errors." Right (_,rSpn) -> toBufSpan rSpn processToken occFile spanIdentifiedByLexer otherFiles let convertResult :: RealSrcSpan -> (FilePath,BufSpan) convertResult r = (unpackFS $ srcSpanFile r,toBufSpan r) return $ map (\x -> convertResult x) resLocs showOccurrencesOfResult :: [(FilePath,BufSpan)] -> String showOccurrencesOfResult elems = sOORAcc [] elems where sOORAcc :: [String] -> [(FilePath,BufSpan)] -> String sOORAcc acc [] = unlines $ reverse acc sOORAcc acc ((f,(BufSpan (BufLoc l1 c1) (BufLoc l2 c2))):r) = sOORAcc ((f ++ ' ':(show l1) ++ ' ':(show c1) ++ ' ':(show l2) ++ ' ':(show c2)):acc) r -- | This function detects what is at the position specified (the token) and -- according to this information it searches all references to this thing. processToken :: GhcMonad m => FilePath -> BufSpan -> [FilePath] -> m [RealSrcSpan] processToken occFile spn@(BufSpan (BufLoc _ c1) (BufLoc _ c2)) otherFiles = do what <- whatIsAt occFile spn let tryProcessTokenAsName4ABinding :: GhcMonad m => Name -> m [RealSrcSpan] tryProcessTokenAsName4ABinding n = do funBindInfo <- searchFunctionBindingForNameM (n,spn,occFile) let bindingFile :: [FilePath] bindingFile = let ((L l _),_) = result funBindInfo in case srcSpanFileName_maybe l of Nothing -> [] Just fs -> [normalise $ unpackFS fs] referrers <- foldM (accumulateThingsThatRefer (name funBindInfo)) [] (bindingFile `union` [occFile] `union` otherFiles) definitions <- case fst $ result funBindInfo of (L _ (FunBind { fun_infix = True })) -> do liftIO $ hPutStrLn stderr $ "The token refers to a infix binding which is not fully supported.\n" ++ "Some occurrences (especially the definition itself) may be missing." return [] (L _ b@(FunBind { fun_infix = False })) -> return $ realSrcSpansOfBinding (c2 - c1) b (L _ (PatBind {})) -> do liftIO $ hPutStrLn stderr $ "The token refers to a so-called 'pattern binding' which is not fully supported\n." ++ "Some occurrences (especially the definition itself) may be missing." return [] _ -> -- According to the docs VarBind and AbsBinds should only occure AFTER typechecking. error "Internal error (unexpected VarBind or AbsBinds)" return $ definitions ++ referrers let tryProcessTokenAsFunParam :: GhcMonad m => Name -> m [RealSrcSpan] tryProcessTokenAsFunParam nm = do let -- | This function is used to create a generic SYB-query to collect the function -- parameters (usually only one) that start at a certain location. locateFunParamsQ :: BufLoc -> LPat Name -> [LPat Name] locateFunParamsQ l x@(L (RealSrcSpan r) (VarPat _)) | l == (spanStart $ toBufSpan r) = [x] locateFunParamsQ _ _ = [] funParamInfo <- searchTokenForNameM (nm,spn,occFile) [] (++) (\x -> mkQ [] (locateFunParamsQ x)) definitionLoc <- case result funParamInfo of [] -> error "Internal error (this is unexpectedly no function parameter)" [(L (RealSrcSpan l) _)] -> return l _ -> error "Internal error (unexpected ambiguity concerning function parameters)" referrers <- do setTargets [fileToTarget occFile] _ <- load LoadAllTargets -- Depending on the HscTarget this will create -- intermediate files (set HscNothing to -- suppress) (_,currentModSum) <- searchModGraphFor (Left occFile) renSource <- extractRenamedAST currentModSum let locateLHsExprThatReferTo :: BufLoc -> LHsExpr Name -> [LHsExpr Name] locateLHsExprThatReferTo l1 x@(L (RealSrcSpan _) (HsVar n)) = case nameSrcSpan n of UnhelpfulSpan _ -> [] RealSrcSpan r -> if l1 == l2 then [x] else [] where l2 = spanStart $ toBufSpan r locateLHsExprThatReferTo _ _ = [] genericQuery :: GenericQ [LHsExpr Name] genericQuery = mkQ [] (locateLHsExprThatReferTo $ spanStart $ toBufSpan definitionLoc) let exprs = queryRenamedAST [] (++) genericQuery renSource return [ r | (L (RealSrcSpan r) _) <- exprs ] return $ [definitionLoc] ++ referrers case what of ThereIsAName n -> tryProcessTokenAsName4ABinding n `gcatch` ((\_ -> tryProcessTokenAsFunParam n) :: GhcMonad m => SearchTokenException -> m [RealSrcSpan]) ThereIsABinding n -> tryProcessTokenAsName4ABinding n ThereIsAFunParameter n -> tryProcessTokenAsFunParam n UnknownElement -> -- This point is currently never reached as -- the lexer function will throw if it doesn't find -- a qualified or non-qualified variable. error $ "Unsupported operation. " ++ "Currently only names for bindings and function parameters are supported." -- | This function is responsible to detect what kind of thing is located at -- the passed src-span (the token). whatIsAt :: GhcMonad m => FilePath -> BufSpan -> m WhatIsAtResult whatIsAt filename (BufSpan startLoc@(BufLoc _ c1) (BufLoc _ c2)) = do tokenIsName <- do let considerLHsExprVar :: LHsExpr Name -> BufLoc -> Maybe BufSpan considerLHsExprVar (L (RealSrcSpan r) (HsVar _ )) bl = if (spanStart $ toBufSpan r) == bl then Just $ toBufSpan r else Nothing considerLHsExprVar _ _ = Nothing things <- getThingsAt considerLHsExprVar filename startLoc case things of [(L _ (HsVar n))] -> return $ ThereIsAName n _ -> return $ UnknownElement tokenIsValBind <- do let considerBindsAt :: LHsBindLR Name Name -> BufLoc -> Maybe BufSpan considerBindsAt (L (RealSrcSpan r) b@(FunBind {})) bl = let allSpansOfThisBinding = realSrcSpansOfBinding (c2 - c1) b foldArg :: Bool -> RealSrcSpan -> Bool foldArg True _ = True foldArg _ rs = (spanStart $ toBufSpan rs) == bl in if foldl foldArg False allSpansOfThisBinding then Just $ toBufSpan r else Nothing considerBindsAt _ _ = Nothing funBinds <- getThingsAt considerBindsAt filename startLoc case funBinds of [(L _ (FunBind { fun_id = (L _ n) }))] -> return $ ThereIsABinding n _ -> return $ UnknownElement tokenIsFunParameter <- do let considerLPat :: LPat Name -> BufLoc -> Maybe BufSpan considerLPat (L (RealSrcSpan r) (VarPat _)) bl = if (spanStart $ toBufSpan r) == bl then Just $ toBufSpan r else Nothing considerLPat _ _ = Nothing things <- getThingsAt considerLPat filename startLoc case things of [(L _ (VarPat n))] -> return $ ThereIsAFunParameter n _ -> return $ UnknownElement let orIfUnknown :: WhatIsAtResult -> WhatIsAtResult -> WhatIsAtResult orIfUnknown UnknownElement x = x orIfUnknown x _ = x return $ tokenIsName `orIfUnknown` tokenIsValBind `orIfUnknown` tokenIsFunParameter -- | This function searches the passed file for variables, import- or export- -- declarations that refer to the name passed as first parameter. accumulateThingsThatRefer :: GhcMonad m => Name -> [RealSrcSpan] -> FilePath -> m [RealSrcSpan] accumulateThingsThatRefer defName acc currentFile = do setTargets [fileToTarget currentFile] _ <- load LoadAllTargets -- Depending on the HscTarget this will create -- intermediate files (set HscNothing to -- suppress) (_,currentModSum) <- searchModGraphFor (Left currentFile) renSource <- extractRenamedAST currentModSum -- There is one problem when searching for 'Name's that refer to something. -- There is the possibility that it is qualified (like for example -- 'A.hello'). For these cases we have to remember how long the name -- actually is and have to shorten the RealSrcSpan by the prefix ('A.)'. let spanLength :: BufSpan -> Int spanLength (BufSpan (BufLoc _ c1) (BufLoc _ c2)) = (c2 - c1) originalLength :: Int originalLength = spanLength $ spanToBufSpan $ nameSrcSpan defName where spanToBufSpan :: SrcSpan -> BufSpan spanToBufSpan (RealSrcSpan r) = toBufSpan r spanToBufSpan _ = error "Internal error (unexpected unhelpful span in accumulateThingsThatRefer)" referrers :: [RealSrcSpan] referrers = let getReferrerFromIE :: Name -> LIE Name -> [RealSrcSpan] getReferrerFromIE refName (L (RealSrcSpan r) (IEVar n)) | (refName == n) = [r] getReferrerFromIE _ _ = [] getReferrerFromTypeSig :: Name -> Sig Name -> [RealSrcSpan] getReferrerFromTypeSig refName (TypeSig lNames _) = case filter (\(L _ x) -> x == refName) lNames of [L (RealSrcSpan r) _] -> [r] _ -> [] getReferrerFromTypeSig _ _ = [] getReferrersFromExprs :: Name -> LHsExpr Name -> [RealSrcSpan] getReferrersFromExprs refName (L (RealSrcSpan r) (HsVar n)) | (refName == n) = let oldEnd = realSrcSpanEnd r newBeg = mkRealSrcLoc (srcLocFile oldEnd) (srcLocLine oldEnd) ((srcLocCol oldEnd) - originalLength) in [mkRealSrcSpan newBeg oldEnd] getReferrersFromExprs _ _ = [] genericQuery :: GenericQ [RealSrcSpan] genericQuery = mkQ [] (getReferrerFromIE defName) `extQ` (getReferrerFromTypeSig defName) `extQ` (getReferrersFromExprs defName) in queryRenamedAST [] (++) genericQuery renSource return $ acc ++ referrers data WhatIsAtResult = -- | Names are used for value- and function bindings -- as well as function parameters. ThereIsAName Name -- | FunBinds contain a 'fun_id' which contain a 'Name' -- that points to itself. This gives us the opportunity to -- treat names and function bindings equal (for both the -- occurrences are searched with a name in hand). The other -- possibility would be to have a 'HsBindLR Name Name' -- instance here. | ThereIsABinding Name -- | Function parameters are of type (LPat Name) at the -- location where they are defined. | ThereIsAFunParameter Name | UnknownElement -- | This function extracts the RealSrcSpan elements of a function binding. -- -- This is the heading @myfunction@ in @myfunction x = x * x@. realSrcSpansOfBinding :: Int -- ^ Length of the function name (determined by the lexer) -> HsBindLR Name Name -- ^ The actual binding -> [RealSrcSpan] -- ^ A list with one name for each match of the -- function (or [] if this is a pattern binding or -- infix declaration) realSrcSpansOfBinding funNameLen (FunBind { fun_infix = False , fun_matches = (MatchGroup lmatches _) }) = -- A function binding does not contain its Name instance explicitely. This -- is a problem at this point and the only way to surround it is to guess -- that the name of the function always starts with the match. This is also -- the reason why infix notation currently isn't supported (extracting the -- extract name of the function is a little tricky isn't it?) let extractNameSpanFromLMatch :: Int -> LMatch Name -> [RealSrcSpan] extractNameSpanFromLMatch len (L (RealSrcSpan l) _) = let sta = realSrcSpanStart l (sl,sc) = (srcLocLine sta,srcLocCol sta) -- We extract the file name to be able to normalise it f = fsLit $ normalise $ unpackFS $ srcLocFile sta s = mkRealSrcLoc f sl sc e = mkRealSrcLoc f sl (sc + len) in [mkRealSrcSpan s e] extractNameSpanFromLMatch _ _ = [] in concatMap (extractNameSpanFromLMatch funNameLen) lmatches realSrcSpansOfBinding _ _ = []