libhbb-0.1.1.1: Language/Haskell/HBB/OccurrencesOf.hs
{-# 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 _ _ _ = []