{-# 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.Directory (getCurrentDirectory) import System.FilePath (normalise,makeRelative) 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 -- -- This file deals with the renaming of names that point to bindings (value and -- function bindings but not pattern bindings). -- -- | This is the function that is applied to all pathes that are written to -- stdout. The decision is to print all pathes as relative pathes. relativeAndNormalisedPath :: FilePath -> FilePath -> FilePath relativeAndNormalisedPath cwd path = makeRelative cwd $ normalise path -- | This function takes a location, searches out what is at this location and -- then returns a list of all occurrences of this identifier. This currently -- works for names of function- and value bindings. occurrencesOf :: [String] -- ^ A list of ghc options (e.g. @["-isrc"]@) -> FilePath -- ^ The file where the token to rename resides in -> BufLoc -- ^ The location where the token to rename is -> [FilePath] -- ^ A list of further files which possibly contain this token and -- which should be searched for it -> IO [(FilePath,BufSpan)] occurrencesOf ghcOptions filename reqLoc otherFiles = runGhcWithCmdLineFlags ghcOptions (Just libdir) $ occurrencesOfM filename reqLoc otherFiles -- | This is the monadic version of occurrencesOf which allows to use this mode -- of operation from a preconfigured GHC environment. occurrencesOfM :: GhcMonad m => FilePath -> BufLoc -> [FilePath] -> m [(FilePath,BufSpan)] occurrencesOfM occFile' loc otherFiles' = do cwd <- liftIO $ getCurrentDirectory -- We normalize the filenames to be able to use 'union' from -- 'Data.List' to merge them. let occFile = (relativeAndNormalisedPath cwd) occFile' otherFiles = map (relativeAndNormalisedPath cwd) 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 cwd occFile spanIdentifiedByLexer otherFiles let convertResult :: RealSrcSpan -> (FilePath,BufSpan) convertResult r = (unpackFS $ srcSpanFile r,toBufSpan r) return $ map (\x -> convertResult x) resLocs -- | This Function formats the results from the occurrencesOf or occurrencesOfM -- function. 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 -> FilePath -> BufSpan -> [FilePath] -> m [RealSrcSpan] processToken cwd occFile spn@(BufSpan (BufLoc _ c1) (BufLoc _ c2)) otherFiles = do 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 -> [relativeAndNormalisedPath cwd $ 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 cwd (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 what <- whatIsAt cwd occFile spn case what of ThereIsAName n -> tryProcessTokenAsName4ABinding n `gcatch` ((\_ -> tryProcessTokenAsFunParam n) :: GhcMonad m => SearchTokenException -> m [RealSrcSpan]) ThereIsABinding n -> tryProcessTokenAsName4ABinding n ThereIsAFunParameter n -> tryProcessTokenAsFunParam n ThereIsATypeSigFor n -> tryProcessTokenAsName4ABinding 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 -- ^ The current working directory (to normalize pathes...) -> FilePath -> BufSpan -> m WhatIsAtResult whatIsAt cwd 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 cwd (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 filterByStartLoc :: BufLoc -> Located Name -> Bool filterByStartLoc bl' (L (RealSrcSpan r) _) = (spanStart $ toBufSpan r) == bl' filterByStartLoc _ _ = False tokenIsFunSignature <- do let considerLSig :: LSig Name -> BufLoc -> Maybe BufSpan considerLSig (L (RealSrcSpan _) (TypeSig lnames _)) bl = case filter (filterByStartLoc bl) lnames of [(L (RealSrcSpan r) _)] -> Just $ toBufSpan r _ -> Nothing considerLSig _ _ = Nothing sigs <- getThingsAt considerLSig filename startLoc case sigs of [(L (RealSrcSpan _) (TypeSig lnames _))] -> case filter (filterByStartLoc startLoc) lnames of [L _ n] -> return $ ThereIsATypeSigFor n _ -> return UnknownElement _ -> return UnknownElement let orIfUnknown :: WhatIsAtResult -> WhatIsAtResult -> WhatIsAtResult orIfUnknown UnknownElement x = x orIfUnknown x _ = x return $ tokenIsName `orIfUnknown` tokenIsValBind `orIfUnknown` tokenIsFunParameter `orIfUnknown` tokenIsFunSignature -- | 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 | ThereIsATypeSigFor Name | UnknownElement -- | This function extracts the RealSrcSpan elements of a function binding. -- -- This is the heading @myfunction@ in @myfunction x = x * x@. realSrcSpansOfBinding :: FilePath -- ^ The current working directory (to normalize pathes) -> 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 cwd 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 $ relativeAndNormalisedPath cwd $ 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 _ _ _ = []