libhbb-0.1.1.0: Language/Haskell/HBB/Internal/GHCHighlevel.hs
{-# LANGUAGE RankNTypes,DeriveDataTypeable #-}
{-# OPTIONS -Wall #-}
module Language.Haskell.HBB.Internal.GHCHighlevel (
searchFunctionBinding,
searchFunctionBindingM,
searchFunctionBindingForNameM,
searchTokenForNameM,
getThingsAt,
getSortedLHsExprsAt, SearchTokenException(..),
GetVariableLexerException(..),
SearchedTokenInfo(..),
FunBindInfo,
BufSpan(..),
BufLoc(..)
) where
-- This file contains a high-level wrapper for GHC functionalities. It uses
-- the lower-level functionalities from GHC, AST and Lexer to provide
-- easy-to-use blocks of functionalities.
--
-- +-----------------+
-- | LibGHCHighlevel |
-- +-----------------+
-- | | |
-- | | |
-- +---------+ | +-------+----------+
-- | | | |
-- v v v v
-- +----+ +-----+ +-------+ +---------+
-- |GHC | | AST | | Lexer | | SrcSpan |
-- +----+ +-----+ +-------+ +---------+
--
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 GHC.Paths (libdir) -- GHC.Paths is available via cabal install ghc-paths
import GhcMonad
import SrcLoc (realSrcSpanStart,realSrcSpanEnd,mkRealSrcSpan,mkRealSrcLoc)
import Name (nameModule_maybe)
import GHC
-- FunBindInfo is the type returned by the function 'searchFunctionBinding'.
data SearchedTokenInfo a = SearchedTokenInfo {
-- | GHC internally uses Outputable for things that may be
-- printed to the user for example. As the printing functions
-- depend on the DynFlags used at compilation they can't be
-- used any more when the GHC run has finished. So 'printFun'
-- uses a closure to save the DynFlags in a curried function
-- to make it possible for clients to get a string
-- representation of a GHC internal data type.
printFun :: (forall b. Outputable b => b -> String)
-- | This is the Src-Span covering the full function name the
-- searchFunctionBinding function has determined (the
-- function gets passed only a certain point in a file
-- pointing to a (part) of the function name)
, occSpan :: RealSrcSpan
-- | The name that was at the location that has been passed to
-- searchFunctionBinding(M). In the case of inlining the name
-- is what is to be replaced by the function definition. This
-- name is completely enclosed by occSpan.
, name :: Name
-- | The type of the result is determined by the GenericQ a
-- passed as parameter.
, result :: a }
type FunBindInfo = SearchedTokenInfo (LHsBindLR Name Name,Maybe (LSig Name))
-- | These are exceptions searchFunctionBinding(M) may throw.
--
-- Each exception can be converted to a meaningful string. Moreover
-- searchFunctionBinding is throwing internal errors via error (exception
-- ErrorCall must be catched).
data SearchTokenException = LexingSearchError GetVariableLexerException
| TokenIsntAName
| TokenNotEndingAccordingly
| IsFunctionApplication
| IsExternalName ModuleName
| IsntNameOfABinding -- The name at this location refers to for example a function parameter
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
-- | Parses the renamed AST of the module and returns all elements that start
-- at the passed location sorted by length in increasing oder.
getThingsAt
:: (GhcMonad m,Typeable a)
-- | Tells how to extract the span of an a. If the a element is at the
-- BufLoc specified then the according BufSpan is returned. Note that the
-- results are sorted by the end location of the BufSpan that is returned
-- here. So if this function returns weird data then the sorting of the
-- results is not warranted.
=> (a -> BufLoc -> Maybe BufSpan)
-> FilePath -- ^ The filename of the module that should be considered.
-> BufLoc -- ^ The required start-location of the tokens.
-> m [a] -- ^ A sorted list of results.
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
-- | Returns a list of (LHsExpr Name) instances that start at the passed
-- position. The first instance is the shortest match which means that it spans
-- fewest character. This is the name of the function that should be applied or
-- the name of the value bindings.
getSortedLHsExprsAt :: GhcMonad m => FilePath -> BufLoc -> m [LHsExpr Name]
getSortedLHsExprsAt filename location = getThingsAt extractBufSpan filename 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
-- | This function takes a file name and the location that is of interest and
-- searches out the value or function binding for the name that stands at this
-- location. The returned value contains all informations that are needed to
-- inline the function definition or describe how to inline it (smart-inline).
--
-- If the name refers to a name that is not part of the module graph (because
-- it has been loaded by a library for example) this function will fail.
searchFunctionBinding :: FilePath -> BufLoc -> Maybe BufLoc -> IO FunBindInfo
searchFunctionBinding filename loc1 mbBL =
runGhc (Just libdir) $ searchFunctionBindingM filename loc1 mbBL
-- | This is the monadic version of searchFunctionBinding which assumes that
-- there is a preconfigured GHC.
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) ExcludeQualifiedVars
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)
-- We search out the name that is at the position specified.
-- With the name it is possible to get out the module and the location
-- where the function or value bindings is defined.
ourName <- do
-- getSortedLHsExprsAt returns a sorted list where the first element covers
-- the smallest range (it is directly a (LHsExpr Name) and no function
-- application).
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)
-- | This version to search a function binding takes a Name and some details
-- about it.
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
-- This function is used to create a generic SYB-query to collect the function
-- bindings (usually only one) start start at a certain location.
locateFunctionsQ :: BufLoc -> (LHsBindLR Name Name) -> FunBindAndSig
locateFunctionsQ loc x@(L l (FunBind {})) | hasSearchedStartLoc loc l = FunBindAndSig [x] []
-- Pattern bindings (e.g. sq :: Int -> Int = \x -> x * x)
-- are also collected to be able to give a clear message to the user...
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 -- [LSig Name]
sigQ na _ (ValBindsOut _ x) = FunBindAndSig [] (filter isCorrectSig x)
where
-- Tests proved that the location stored within
-- (LSig Name) contains weird data. Therefore the
-- name is used for the comparison (which should be
-- better anyway)...
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) }
-- | This is a generic function that takes informations about a Name and
-- queries the renamed AST according to the parameters.
searchTokenForNameM
:: GhcMonad m
=> (Name,BufSpan,FilePath) -- ^ informations about the Name instance, its location and the file
-> b -- ^ neutral result
-> (b -> b -> b) -- ^ function to join 2 results
-> (BufLoc -> GenericQ b) -- ^ generic query (special cases) for the
-- result, produced by 'mkQ' for example...
-> m (SearchedTokenInfo b)
searchTokenForNameM (ourName,nameSpan,filename) neutralResult joinResult queryResult = do
let startLoc = case nameSrcSpan ourName of
(RealSrcSpan rss) -> toBufLoc $ realSrcSpanStart rss
_ ->
-- In this case the name doesn't refer to the current unit of compilation
-- but to a library. We throw an exception but insert the module name.
throw $ IsExternalName (moduleName $ nameModule ourName)
renamedAST <- do
modSum <- do
-- Ok now there are two possibilities.
-- Either the name refers to something at module scope (a name
-- defined in this or another module) or it refers to a nested
-- function binding.
-- In the first case 'nameModule_maybe' will return the module of
-- interest. In the second case the binding must be located in the
-- same module as the name. We cycle through the module graph to
-- find the current module and return it.
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 })