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 Control.Monad (foldM)
import Data.Generics
import FastString (unpackFS)
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
cwd <- liftIO $ getCurrentDirectory
let occFile = (normalisePath cwd) occFile'
otherFiles = map (normalisePath 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
return $ map (\x -> unpackRealSrcSpan x) resLocs
showOccurrencesOfResult
:: [(FilePath,BufSpan)]
-> String
showOccurrencesOfResult elems = sOORAcc [] elems
where
sOORAcc :: [String] -> [(FilePath,BufSpan)] -> String
sOORAcc acc [] = unlines $ reverse acc
sOORAcc acc (e:r) = sOORAcc ((showSpan Nothing e):acc) r
processToken :: GhcMonad m => FilePath -> FilePath -> BufSpan -> [FilePath] -> m [RealSrcSpan]
processToken cwd occFile spn@(BufSpan (BufLoc _ c1) (BufLoc _ c2)) otherFiles = do
let processTokenAsBinding :: GhcMonad m => (LHsBindLR Name Name) -> m [RealSrcSpan]
processTokenAsBinding (L _ (PatBind _ _ _ _ _) ) = error "The token refers to a so-called pattern binding which aren't supported so far."
processTokenAsBinding (L _ (AbsBinds _ _ _ _ _) ) = error "Internal error (unexpected AbsBinds in the renamed AST)."
processTokenAsBinding (L _ (VarBind _ _ _ ) ) = error "Internal error (unexpected VarBind in the renamed AST)."
processTokenAsBinding (L rs bind@(FunBind { fun_id = (L _ n) } ) ) = do
let bindingFile :: [FilePath]
bindingFile = case srcSpanFileName_maybe rs of
Nothing -> []
Just fs -> [normalisePath cwd $ unpackFS fs]
referrers <- foldM
(accumulateThingsThatRefer n)
[] (bindingFile `union` [occFile] `union` otherFiles)
definitions <- return $ realSrcSpansOfBinding (c2 c1) bind
return $ definitions ++ referrers
let processTokenAsFunParam :: GhcMonad m => LPat Name -> m [RealSrcSpan]
processTokenAsFunParam (L (RealSrcSpan rs) (VarPat _)) = do
referrers <- do
setTargets [fileToTarget occFile]
_ <- load LoadAllTargets
(_,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 rs)
let exprs = queryRenamedAST [] (++) genericQuery renSource
return [ r | (L (RealSrcSpan r) _) <- exprs ]
return $ [rs] ++ referrers
processTokenAsFunParam _ = error "Internal error (unsupported instance of LPat Name)"
what <- whatIsAt occFile spn
locs <- case what of
ThereIsAnExternalName _ -> error $ "The token is referring to external functionality"
ThereIsAnIEDeclToExtern _ -> error $ "Import/Export declaration is referring to external functionality"
ThereIsAnIEDeclFor (ThereIsABinding b) -> processTokenAsBinding b
ThereIsAnIEDeclFor _ -> error "Internal error (unexpected reference to non-binding in IEDecl)"
ThereIsANameFor (ThereIsABinding b) -> processTokenAsBinding b
ThereIsANameFor (ThereIsAFunParameter p) -> processTokenAsFunParam p
ThereIsANameFor _ -> error "Internal error (the name is referencing unexpected things)"
ThereIsABinding b -> processTokenAsBinding b
ThereIsAFunParameter p -> processTokenAsFunParam p
ThereIsATypeSigFor (ThereIsABinding b) -> processTokenAsBinding b
ThereIsATypeSigFor _ -> error "Internal error (name from type-sig is referencing unexpected things)"
UnknownElement ->
error $ "Unsupported operation. " ++
"Currently only names for bindings and function parameters are supported.\n" ++
"Moreover the infix notation in function definitions isn't supported either"
let normaliseRealSrcSpan :: RealSrcSpan -> RealSrcSpan
normaliseRealSrcSpan r =
let (f,bs) = unpackRealSrcSpan r
in packRealSrcSpan (normalisePath cwd f,bs)
return $ map normaliseRealSrcSpan locs
accumulateThingsThatRefer :: GhcMonad m => Name -> [RealSrcSpan] -> FilePath -> m [RealSrcSpan]
accumulateThingsThatRefer defName acc currentFile = do
setTargets [fileToTarget currentFile]
_ <- load LoadAllTargets
(_,currentModSum) <- searchModGraphFor (Left currentFile)
renSource <- extractRenamedAST currentModSum
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 getReferrersFromIE :: Name -> LIE Name -> [RealSrcSpan]
getReferrersFromIE refName (L (RealSrcSpan r) (IEVar n)) | (refName == n) = [r]
getReferrersFromIE _ _ = []
getReferrersFromTypeSig :: Name -> Sig Name -> [RealSrcSpan]
getReferrersFromTypeSig refName (TypeSig lNames _) =
case filter (\(L _ x) -> x == refName) lNames of
[L (RealSrcSpan r) _] -> [r]
_ -> []
getReferrersFromTypeSig _ _ = []
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 [] (getReferrersFromIE defName) `extQ`
(getReferrersFromTypeSig defName) `extQ`
(getReferrersFromExprs defName)
in queryRenamedAST [] (++) genericQuery renSource
return $ acc ++ referrers