libhbb-0.1.1.0: 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.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 _ _ = []