module Language.Haskell.HBB.Internal.GHCHighlevel (
searchFunctionBindingM,
searchFunctionBindingForNameM,
searchTokenForNameM,
whatIsAt,
WhatIsAt(..),
realSrcSpansOfBinding,
getThingsAt,
SearchTokenException(..),
LexingFailReason(..),
SearchedTokenInfo(..),
FunBindInfo,
BufSpan(..),
BufLoc(..)
) where
import Language.Haskell.HBB.Internal.SrcSpan
import Language.Haskell.HBB.Internal.Lexer
import Language.Haskell.HBB.Internal.AST
import Language.Haskell.HBB.Internal.GHC
import Control.Exception (throw,Exception)
import Data.Generics
import FastString (mkFastString)
import Outputable
import Data.Maybe (fromJust)
import Data.List (sortBy)
import GhcMonad
import SrcLoc (realSrcSpanStart,realSrcSpanEnd,mkRealSrcSpan,mkRealSrcLoc)
import Name (nameModule_maybe)
import GHC
data SearchedTokenInfo a = SearchedTokenInfo {
printFun :: (forall b. Outputable b => b -> String)
, occSpan :: RealSrcSpan
, name :: Name
, result :: a }
type FunBindInfo = SearchedTokenInfo (LHsBindLR Name Name,Maybe (LSig Name))
data SearchTokenException = LexingSearchError LexingFailReason
| TokenIsntAName
| TokenNotEndingAccordingly
| IsFunctionApplication
| IsExternalName ModuleName
| IsntNameOfABinding
deriving (Typeable)
instance Show SearchTokenException where
show (LexingSearchError LexingFailed) = "Lexing failed. Input file isn't valid Haskell"
show (LexingSearchError VarNotFound ) = "There is no variable at the specififed location"
show TokenIsntAName = "Didn't find an name at the specified location.\n" ++
"(Is this really an expression or something like a function parameter?)"
show TokenNotEndingAccordingly = "There is at least one name starting at the location but none ending accordingly.\n" ++
"Did you specify the end of the source-span correctly?"
show IsFunctionApplication = "This seems to be a function application of which inlining isn't supported so far."
show (IsExternalName m) = "The name refers to an external binding (module " ++ moduleNameString m ++ ")"
show IsntNameOfABinding = "No according function binding found.\n" ++
"Is this really the name of a binding (or for example a parameter to a function)?"
instance Exception SearchTokenException
getThingsAt
:: (GhcMonad m,Typeable a)
=> (a -> BufLoc -> Maybe BufSpan)
-> FilePath
-> BufLoc
-> m [a]
getThingsAt isAtLoc filename location = do
loadTargetsFromFilename filename
let asTypeOf' :: a -> (a -> BufLoc -> Maybe BufSpan) -> a
asTypeOf' a _ = a
checkedMod <- searchModGraphFor (Left filename) >>= return . snd >>= parseModule >>= typecheckModule
let rnSource = fromJust $ tm_renamed_source checkedMod
locateIt s x = case isAtLoc x s of
Nothing -> []
Just (BufSpan _ e) -> [(x,e)]
collectedExprs = queryRenamedAST [] (++) (mkQ [] (\x -> locateIt location (asTypeOf' x isAtLoc))) rnSource
return $ map fst $ sortBy sortByEnding collectedExprs
where
sortByEnding :: (a,BufLoc) -> (a,BufLoc) -> Ordering
sortByEnding (_,end1) (_,end2) = end1 `compare` end2
searchFunctionBindingM :: GhcMonad m => FilePath -> BufLoc -> Maybe BufLoc -> m FunBindInfo
searchFunctionBindingM filename loc1 mbBL = do
updateDynFlagsToSuppressFileOutput
(blStart,blEnd) <- case mbBL of
Nothing -> do
lexerResult <- getVariableIdUsingLexerAt (filename,loc1) IncludeQualifiedVars
let (_,rSpan) = case lexerResult of Right x -> x
Left x -> throw (LexingSearchError x)
return ((toBufLoc $ realSrcSpanStart rSpan)
,(toBufLoc $ realSrcSpanEnd rSpan))
Just loc2 -> return (loc1,loc2)
ourName <- do
let
getSortedLHsExprsAt :: GhcMonad m => FilePath -> BufLoc -> m [LHsExpr Name]
getSortedLHsExprsAt fn' location = getThingsAt extractBufSpan fn' location
where extractBufSpan :: LHsExpr Name -> BufLoc -> Maybe BufSpan
extractBufSpan (L (RealSrcSpan r) (HsVar _ )) bl = if (spanStart $ toBufSpan r) == bl then Just $ toBufSpan r else Nothing
extractBufSpan (L (RealSrcSpan r) (HsApp _ _)) bl = if (spanStart $ toBufSpan r) == bl then Just $ toBufSpan r else Nothing
extractBufSpan _ _ = Nothing
exprs <- getSortedLHsExprsAt filename blStart
let endsAt :: SrcSpan -> BufLoc -> Bool
endsAt (RealSrcSpan r) l = l == (toBufLoc $ realSrcSpanEnd r)
endsAt _ _ = False
case exprs of
[] -> throw TokenIsntAName
xs -> case [ e | (L l e) <- xs , l `endsAt` blEnd ] of
[] -> throw TokenNotEndingAccordingly
[(HsVar n)] -> return n
[(HsApp _ _)] -> throw IsFunctionApplication
_ -> error "Internal error (too much results for matching expressions)."
searchFunctionBindingForNameM (ourName,(BufSpan blStart blEnd),filename)
data FunBindAndSig = FunBindAndSig [LHsBindLR Name Name] [LSig Name]
joinFunBindAndSig :: FunBindAndSig -> FunBindAndSig -> FunBindAndSig
joinFunBindAndSig (FunBindAndSig b1 s1) (FunBindAndSig b2 s2) = FunBindAndSig (b1 ++ b2) (s1 ++ s2)
searchFunctionBindingForNameM :: GhcMonad m => (Name,BufSpan,FilePath) -> m FunBindInfo
searchFunctionBindingForNameM (ourName,nameSpan,filename) = do
let genericQuery :: BufLoc -> GenericQ FunBindAndSig
genericQuery =
let hasSearchedStartLoc :: BufLoc -> SrcSpan -> Bool
hasSearchedStartLoc loc (RealSrcSpan rss) =
loc == (toBufLoc $ realSrcSpanStart rss)
hasSearchedStartLoc _ _ = False
locateFunctionsQ :: BufLoc -> (LHsBindLR Name Name) -> FunBindAndSig
locateFunctionsQ _ x@(L _ (FunBind {
fun_id = (L _ itsName) })) | (ourName == itsName) = FunBindAndSig [x] []
locateFunctionsQ loc x@(L l (FunBind {})) | hasSearchedStartLoc loc l = FunBindAndSig [x] []
locateFunctionsQ loc x@(L l (PatBind {})) | hasSearchedStartLoc loc l = FunBindAndSig [x] []
locateFunctionsQ _ (L _ (VarBind {})) =
error $ "Internal error (unexpected VarBind: " ++
"GHC doc says that they are introduced by the typechecker)"
locateFunctionsQ _ (L _ (AbsBinds {})) =
error $ "Internal error (unexpected AbsBind: " ++
"GHC doc says that they are introduced by the typechecker)"
locateFunctionsQ _ _ = FunBindAndSig [] []
sigQ :: Name -> BufLoc -> HsValBindsLR Name Name -> FunBindAndSig
sigQ na _ (ValBindsOut _ x) = FunBindAndSig [] (filter isCorrectSig x)
where
isCorrectSig :: LSig Name -> Bool
isCorrectSig (L _ (TypeSig lNames _)) = any (\(L _ n) -> n == na) lNames
isCorrectSig _ = False
sigQ _ _ _ = FunBindAndSig [] []
in (\x -> mkQ (FunBindAndSig [] []) (locateFunctionsQ x) `extQ` (sigQ ourName x))
sti@(SearchedTokenInfo {
result = (FunBindAndSig funBinds sigs)
}) <-
searchTokenForNameM
(ourName,nameSpan,filename)
(FunBindAndSig [] [])
joinFunBindAndSig
genericQuery
let ourFun = case funBinds of
[] -> throw IsntNameOfABinding
[b@(L _ (FunBind {}))] -> b
[b@(L _ (PatBind {}))] -> b
_ -> error "Internal error (more that one matching function binding found)"
let ourSig = case sigs of
[] -> Nothing
(x:_) -> Just x
fgs <- getSessionDynFlags
return SearchedTokenInfo { printFun = showPpr fgs
, occSpan = occSpan sti
, name = name sti
, result = (ourFun,ourSig) }
searchTokenForNameM
:: GhcMonad m
=> (Name,BufSpan,FilePath)
-> b
-> (b -> b -> b)
-> (BufLoc -> GenericQ b)
-> m (SearchedTokenInfo b)
searchTokenForNameM (ourName,nameSpan,filename) neutralResult joinResult queryResult = do
let startLoc = case nameSrcSpan ourName of
(RealSrcSpan rss) -> toBufLoc $ realSrcSpanStart rss
_ ->
throw $ IsExternalName (moduleName $ nameModule ourName)
renamedAST <- do
modSum <- do
modName <- case nameModule_maybe ourName of
Just m -> return $ moduleName m
Nothing -> searchModGraphFor (Left filename) >>= return . fst
getModSummary modName
extractRenamedAST modSum
let ourResult = queryRenamedAST neutralResult joinResult (queryResult startLoc) renamedAST
occurrenceSpan :: RealSrcSpan
occurrenceSpan =
let (BufLoc l1 c1) = spanStart nameSpan
(BufLoc l2 c2) = spanEnd nameSpan
in mkRealSrcSpan (mkRealSrcLoc (mkFastString filename) l1 c1)
(mkRealSrcLoc (mkFastString filename) l2 c2)
getSessionDynFlags >>= (\fgs -> return SearchedTokenInfo {
printFun = showPpr fgs
, occSpan = occurrenceSpan
, name = ourName
, result = ourResult })
data WhatIsAtIndirection = NoRecursion
| RecFromName
| RecFromSig
| RecFromIEDecl
whatIsAt
:: GhcMonad m
=> FilePath
-> BufSpan
-> m WhatIsAt
whatIsAt = whatIsAtInternal NoRecursion
where
whatIsAtInternal
:: GhcMonad m
=> WhatIsAtIndirection
-> FilePath
-> BufSpan
-> m WhatIsAt
whatIsAtInternal rec filename (BufSpan startLoc@(BufLoc _ c1) (BufLoc _ c2)) = do
let followName :: Name -> Maybe (FilePath,BufSpan)
followName n = case nameSrcSpan n of
UnhelpfulSpan _ -> Nothing
RealSrcSpan rs -> Just (unpackRealSrcSpan rs)
let isTokenName :: GhcMonad m => FilePath -> BufLoc -> m WhatIsAt
isTokenName fn sl = 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 fn sl
case things of
[(L _ (HsVar n))] -> case followName n of
Nothing -> return $ ThereIsAnExternalName n
Just (f,s) -> whatIsAtInternal RecFromName f s
_ -> return $ UnknownElement
let isTokenIEDecl :: GhcMonad m => FilePath -> BufLoc -> m WhatIsAt
isTokenIEDecl fn bl = do
let considerIEDeclAt :: LIE Name -> BufLoc -> Maybe BufSpan
considerIEDeclAt (L (RealSrcSpan r) (IEVar _)) l = if (spanStart $ toBufSpan r) == l
then Just $ toBufSpan r else Nothing
considerIEDeclAt _ _ = Nothing
things <- getThingsAt considerIEDeclAt fn bl
case things of
[(L (RealSrcSpan _) (IEVar n))] ->
case followName n of
Nothing -> return $ ThereIsAnIEDeclToExtern n
Just (f,s) -> whatIsAtInternal RecFromIEDecl f s
_ -> return UnknownElement
let isValBindAt :: GhcMonad m => FilePath -> BufLoc -> m WhatIsAt
isValBindAt fn sl = 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 fn sl
case funBinds of
[b@(L _ (FunBind { fun_id = (L _ _) }))] -> return $
case rec of NoRecursion -> ThereIsABinding b
RecFromName -> ThereIsANameFor (ThereIsABinding b)
RecFromSig -> ThereIsATypeSigFor (ThereIsABinding b)
RecFromIEDecl -> ThereIsAnIEDeclFor (ThereIsABinding b)
_ -> return $ UnknownElement
let isFunParameterAt :: GhcMonad m => FilePath -> BufLoc -> m WhatIsAt
isFunParameterAt fn sl = 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 fn sl
case things of
[p@(L _ (VarPat _))] -> return $
case rec of RecFromName -> ThereIsANameFor (ThereIsAFunParameter p)
_ -> ThereIsAFunParameter p
_ -> return UnknownElement
let filterByStartLoc :: BufLoc -> Located Name -> Bool
filterByStartLoc bl' (L (RealSrcSpan r) _) = (spanStart $ toBufSpan r) == bl'
filterByStartLoc _ _ = False
let isFunSignatureAt :: GhcMonad m => FilePath -> BufLoc -> m WhatIsAt
isFunSignatureAt fn sl = 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 fn sl
case sigs of
[(L (RealSrcSpan _) (TypeSig lnames _))] ->
case filter (filterByStartLoc startLoc) lnames of
[L _ n] -> case followName n of
Nothing -> return UnknownElement
Just (f,s) -> whatIsAtInternal RecFromSig f s
_ -> return UnknownElement
_ -> return UnknownElement
tokenIsName <- isTokenName filename startLoc
tokenIsIEDecl <- isTokenIEDecl filename startLoc
tokenIsValBind <- isValBindAt filename startLoc
tokenIsFunParameter <- isFunParameterAt filename startLoc
tokenIsFunSignature <- isFunSignatureAt filename startLoc
let orIfUnknown :: WhatIsAt -> WhatIsAt -> WhatIsAt
orIfUnknown UnknownElement x = x
orIfUnknown x _ = x
return $ tokenIsName `orIfUnknown`
tokenIsIEDecl `orIfUnknown`
tokenIsValBind `orIfUnknown`
tokenIsFunParameter `orIfUnknown`
tokenIsFunSignature
data WhatIsAt =
ThereIsAnExternalName Name
| ThereIsAnIEDeclToExtern Name
| ThereIsAnIEDeclFor WhatIsAt
| ThereIsANameFor WhatIsAt
| ThereIsABinding (LHsBindLR Name Name)
| ThereIsAFunParameter (LPat Name)
| ThereIsATypeSigFor WhatIsAt
| UnknownElement
realSrcSpansOfBinding
:: Int
-> HsBindLR Name Name
-> [RealSrcSpan]
realSrcSpansOfBinding funNameLen (FunBind { fun_infix = False
, fun_matches = (MatchGroup lmatches _) }) =
let extractNameSpanFromLMatch :: Int -> LMatch Name -> [RealSrcSpan]
extractNameSpanFromLMatch len (L (RealSrcSpan l) _) =
let sta = realSrcSpanStart l
(sl,sc) = (srcLocLine sta,srcLocCol sta)
f = srcLocFile sta
s = mkRealSrcLoc f sl sc
e = mkRealSrcLoc f sl (sc + len)
in [mkRealSrcSpan s e]
extractNameSpanFromLMatch _ _ = []
in concatMap (extractNameSpanFromLMatch funNameLen) lmatches
realSrcSpansOfBinding _ _ = []