diff --git a/Language/Haskell/HBB/ApplyTo.hs b/Language/Haskell/HBB/ApplyTo.hs --- a/Language/Haskell/HBB/ApplyTo.hs +++ b/Language/Haskell/HBB/ApplyTo.hs @@ -12,7 +12,7 @@ -- (everything in the context of the module "Prelude"). -- -- It is expensive as it calls 'ghc' to produce its results. It has been --- created to formally provide the mode 'applyto' but text editors should +-- created to formally provide the mode 'apply-to' but text editors should -- instead use 'ghc' directly. The first argument control whether a warning -- message describing this fact is contained in the result. If it is False then -- the second tuple element of the result will contain an according warning @@ -34,7 +34,7 @@ , std_out = CreatePipe , std_err = UseHandle stderr } - warnMsg = unlines ["> Note that 'applyto' is a small wrapper around a call to 'ghc'." + warnMsg = unlines ["> Note that 'apply-to' is a small wrapper around a call to 'ghc'." ,"> " ,"> The functionality provided here can also be reached by calling 'ghc' as follows:" ,"> " @@ -44,9 +44,7 @@ ,"> In this case the subject strings are written to stdin and the results" ,"> are read from stdout (one per line):" ,"> " - ,(intercalate " " (("> # " ++ exeName):"-e":exeArgQi:[])) - ,"> " - ,"> Use 'applyto -q' to suppress the writing of this message to stderr."] + ,(intercalate " " (("> # " ++ exeName):"-e":exeArgQi:[]))] (_,Just childStdOut,_,_) <- createProcess spec res <- hGetContents childStdOut diff --git a/Language/Haskell/HBB/Internal/GHC.hs b/Language/Haskell/HBB/Internal/GHC.hs --- a/Language/Haskell/HBB/Internal/GHC.hs +++ b/Language/Haskell/HBB/Internal/GHC.hs @@ -74,13 +74,6 @@ } return () -{--- | Searches the module grahp for the passed module-} -{-searchModGraphForModule :: GhcMonad m => Module -> m (ModuleName,ModSummary)-} -{-searchModGraphForModule mod = do-} - {-modGraph <- getModuleGraph-} - {-return $ searchModGraphInternal mod modGraph-} - {-where-} - -- | This function takes a file name or a module and searches the -- module-summary which is based on this source file out of the module graph. searchModGraphFor :: GhcMonad m => Either FilePath Module -> m (ModuleName,ModSummary) diff --git a/Language/Haskell/HBB/Internal/GHCHighlevel.hs b/Language/Haskell/HBB/Internal/GHCHighlevel.hs --- a/Language/Haskell/HBB/Internal/GHCHighlevel.hs +++ b/Language/Haskell/HBB/Internal/GHCHighlevel.hs @@ -1,13 +1,15 @@ {-# LANGUAGE RankNTypes,DeriveDataTypeable #-} {-# OPTIONS -Wall #-} module Language.Haskell.HBB.Internal.GHCHighlevel ( - searchFunctionBinding, searchFunctionBindingM, searchFunctionBindingForNameM, searchTokenForNameM, + whatIsAt, + WhatIsAt(..), + realSrcSpansOfBinding, getThingsAt, - getSortedLHsExprsAt, SearchTokenException(..), - GetVariableLexerException(..), + SearchTokenException(..), + LexingFailReason(..), SearchedTokenInfo(..), FunBindInfo, BufSpan(..), @@ -37,11 +39,10 @@ import Language.Haskell.HBB.Internal.GHC import Control.Exception (throw,Exception) import Data.Generics -import FastString (mkFastString) +import FastString (mkFastString{-,fsLit-}) 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) @@ -78,7 +79,7 @@ -- 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 +data SearchTokenException = LexingSearchError LexingFailReason | TokenIsntAName | TokenNotEndingAccordingly | IsFunctionApplication @@ -135,17 +136,6 @@ 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 @@ -153,12 +143,6 @@ -- -- 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 @@ -179,6 +163,17 @@ -- where the function or value bindings is defined. ourName <- do + let -- 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 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 + -- getSortedLHsExprsAt returns a sorted list where the first element covers -- the smallest range (it is directly a (LHsExpr Name) and no function -- application). @@ -232,7 +227,7 @@ locateFunctionsQ _ _ = FunBindAndSig [] [] - sigQ :: Name -> BufLoc -> HsValBindsLR Name Name -> FunBindAndSig -- [LSig Name] + sigQ :: Name -> BufLoc -> HsValBindsLR Name Name -> FunBindAndSig sigQ na _ (ValBindsOut _ x) = FunBindAndSig [] (filter isCorrectSig x) where -- Tests proved that the location stored within @@ -322,3 +317,178 @@ , occSpan = occurrenceSpan , name = ourName , result = ourResult }) + +-- | This is a internal type used by whatIsAt. +data WhatIsAtIndirection = NoRecursion + | RecFromName + | RecFromSig + +-- | This function is responsible to detect what kind of thing is located at +-- the passed location (the token). +whatIsAt + :: GhcMonad m + -- => FilePath -- ^ The current working directory (to normalize pathes...) + => FilePath -- ^ The file where the token occurred + -> BufSpan -- ^ The location of the token to consider + -> m WhatIsAt +whatIsAt = whatIsAtInternal NoRecursion + where + whatIsAtInternal + :: GhcMonad m + => WhatIsAtIndirection -- ^ Is this a recursive call from following a name/sig... + -> 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) + + 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))] -> case followName n of + Nothing -> return $ ThereIsAnExternalName n + Just (f,s) -> whatIsAtInternal RecFromName {-cwd-} f s + -- in whatIsAt cwd fn ss + -- return $ ThereIsAName n + _ -> 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) + _ -> 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 + + + 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` tokenIsValBind `orIfUnknown` tokenIsFunParameter `orIfUnknown` tokenIsFunSignature + +data WhatIsAt = + -- | Names are used for value- and function bindings as well as + -- function parameters. External names refer to things outside of + -- the module graph (external libraries for example) + ThereIsAnExternalName Name + -- | Names are just pointers to other things. When such a name is + -- discovered, another run of WhatIsAt is triggered which + -- searches for the thing that is at the location pointed to by + -- this name. This can only be a binding (ThereIsABinding) or a + -- function parameter (ThereIsAFunParameter). + | ThereIsANameFor WhatIsAt + -- | The token pointed to a binding. + | ThereIsABinding (LHsBindLR Name Name) + -- | Function parameters are of type (LPat Name) at the location + -- where they are defined. + | ThereIsAFunParameter (LPat Name) + -- | The location specified points to a function or value + -- bindings signature. + | ThereIsATypeSigFor WhatIsAt + -- | There is something that is currently not supported (e.g. a + -- type declaration). + | UnknownElement + +-- | This function extracts the RealSrcSpan elements of a function binding. +-- The problem is that a function binding may contain several entry points of +-- which each has its own src-span attached. Each of these spans will be +-- contained by the result list produced by this function. +-- +-- 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 = srcLocFile sta + s = mkRealSrcLoc f sl sc + e = mkRealSrcLoc f sl (sc + len) + in [mkRealSrcSpan s e] + extractNameSpanFromLMatch _ _ = [] + + in concatMap (extractNameSpanFromLMatch funNameLen) lmatches +realSrcSpansOfBinding _ _ = [] diff --git a/Language/Haskell/HBB/Internal/Lexer.hs b/Language/Haskell/HBB/Internal/Lexer.hs --- a/Language/Haskell/HBB/Internal/Lexer.hs +++ b/Language/Haskell/HBB/Internal/Lexer.hs @@ -2,7 +2,7 @@ module Language.Haskell.HBB.Internal.Lexer ( getVariableIdUsingLexerAt, - GetVariableLexerException(..), + LexingFailReason(..), IncludeQualified(..) ) where @@ -15,8 +15,8 @@ import GHC (getSessionDynFlags) -- | This type holds possible return values of getVariableIdUsingLexerAt. -data GetVariableLexerException = LexingFailed - | VarNotFound +data LexingFailReason = LexingFailed + | VarNotFound data IncludeQualified = IncludeQualifiedVars | ExcludeQualifiedVars @@ -30,7 +30,7 @@ -- then ITqvarid will be ignored. A token of type ITqvarid has two strings -- attached, the name of the module (the qualifier) and the name of the -- variable. Of these twos only the name is contained by the result. -getVariableIdUsingLexerAt :: GhcMonad m => (FilePath,BufLoc) -> IncludeQualified -> m (Either GetVariableLexerException (String,RealSrcSpan)) +getVariableIdUsingLexerAt :: GhcMonad m => (FilePath,BufLoc) -> IncludeQualified -> m (Either LexingFailReason (String,RealSrcSpan)) getVariableIdUsingLexerAt (filename,loc) behaviour = do let wholeFileLoc :: RealSrcLoc wholeFileLoc = mkRealSrcLoc (mkFastString filename) 1 1 diff --git a/Language/Haskell/HBB/Internal/SrcSpan.hs b/Language/Haskell/HBB/Internal/SrcSpan.hs --- a/Language/Haskell/HBB/Internal/SrcSpan.hs +++ b/Language/Haskell/HBB/Internal/SrcSpan.hs @@ -2,7 +2,10 @@ {-# OPTIONS -Wall #-} module Language.Haskell.HBB.Internal.SrcSpan where +import System.Directory (canonicalizePath) +import System.FilePath (normalise,makeRelative) import Data.Generics +import FastString (unpackFS) import Data.Char (isSpace) import SrcLoc @@ -37,6 +40,28 @@ -- | Returns the end location of a BufSpan spanEnd :: BufSpan -> BufLoc spanEnd (BufSpan _ e) = e + +-- | Deconstructs a RealSrcSpan to the types more often used in libhbb. +unpackRealSrcSpan :: RealSrcSpan -> (FilePath,BufSpan) +unpackRealSrcSpan r = (unpackFS $ srcSpanFile r,toBufSpan r) + +normalisePath + :: FilePath -- ^ The current working dir (to make pathes relative) + -> FilePath -- ^ The path that should be adapted + -> FilePath +normalisePath c p = makeRelative c $ normalise p + +-- | This function converts a location in the form libhbb uses it into a +-- string. The string has the format that is used by 'occurrences-of' and +-- 'locate' to report locations to the client. +showSpan + :: FilePath -- ^ The current working dir (to make pathes relative) + -> (FilePath,BufSpan) -- ^ The location to convert to a string + -> String +showSpan cwd (f,(BufSpan (BufLoc sli sco) (BufLoc eli eco))) = + let filePart = normalisePath cwd f + in ('"':filePart ++ "\"") ++ (' ':(show sli)) ++ (' ':(show sco)) ++ + (' ':(show eli)) ++ (' ':(show eco)) -- | This is an auxiliary function that splits a string at all newlines. -- diff --git a/Language/Haskell/HBB/Locate.hs b/Language/Haskell/HBB/Locate.hs --- a/Language/Haskell/HBB/Locate.hs +++ b/Language/Haskell/HBB/Locate.hs @@ -11,7 +11,6 @@ import Language.Haskell.HBB.Internal.GHCHighlevel import Language.Haskell.HBB.Internal.SrcSpan import Language.Haskell.HBB.Internal.GHC -import System.FilePath (normalise) import FastString (unpackFS) import GHC.Paths (libdir) import SrcLoc @@ -38,10 +37,11 @@ -- -- The string has exactly the format that should be understood by text editors -- that are using the mode locate. -showLocateResult :: (FilePath,BufSpan) -> String -showLocateResult (f,(BufSpan (BufLoc sli sco) (BufLoc eli eco))) = - ('"':(normalise f) ++ "\"") ++ (' ':(show sli)) ++ (' ':(show sco)) ++ - (' ':(show eli)) ++ (' ':(show eco)) +showLocateResult + :: FilePath -- ^ The current working dir (to make pathes relative) + -> (FilePath,BufSpan) -- ^ The position that should be converted to string + -> String +showLocateResult cwd loc = showSpan cwd loc -- | This is a variant of locate that runs within the GHC monad and therefore -- allows a more fine-grained control over the behaviour of GHC. diff --git a/Language/Haskell/HBB/OccurrencesOf.hs b/Language/Haskell/HBB/OccurrencesOf.hs --- a/Language/Haskell/HBB/OccurrencesOf.hs +++ b/Language/Haskell/HBB/OccurrencesOf.hs @@ -14,11 +14,9 @@ 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 FastString (unpackFS) import GHC.Paths (libdir) import Data.List (union) import GhcMonad (liftIO) @@ -32,11 +30,6 @@ -- 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. @@ -59,8 +52,8 @@ -- 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' + let occFile = (normalisePath cwd) occFile' + otherFiles = map (normalisePath cwd) otherFiles' resLocs <- do @@ -73,71 +66,46 @@ 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 + return $ map (\x -> unpackRealSrcSpan x) resLocs -- | This Function formats the results from the occurrencesOf or occurrencesOfM -- function. -showOccurrencesOfResult :: [(FilePath,BufSpan)] -> String -showOccurrencesOfResult elems = sOORAcc [] elems +showOccurrencesOfResult + :: FilePath -- ^ The current working dir (to make pathes relative) + -> [(FilePath,BufSpan)] -- ^ The result that should be shown + -> String +showOccurrencesOfResult cwd elems = sOORAcc cwd [] 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 + sOORAcc :: FilePath -> [String] -> [(FilePath,BufSpan)] -> String + sOORAcc _ acc [] = unlines $ reverse acc + sOORAcc c acc (e:r) = sOORAcc c ((showSpan c e):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 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 = - let ((L l _),_) = result funBindInfo - in case srcSpanFileName_maybe l of Nothing -> [] - Just fs -> [relativeAndNormalisedPath cwd $ unpackFS fs] + bindingFile = case srcSpanFileName_maybe rs of + Nothing -> [] + Just fs -> [normalisePath cwd $ unpackFS fs] referrers <- foldM - (accumulateThingsThatRefer (name funBindInfo)) + (accumulateThingsThatRefer n) [] (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)" + definitions <- return $ realSrcSpansOfBinding {-cwd-} (c2 - c1) bind 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)" + let processTokenAsFunParam :: GhcMonad m => LPat Name -> m [RealSrcSpan] + processTokenAsFunParam (L (RealSrcSpan rs) (VarPat _)) = do referrers <- do setTargets [fileToTarget occFile] @@ -159,107 +127,33 @@ locateLHsExprThatReferTo _ _ = [] genericQuery :: GenericQ [LHsExpr Name] - genericQuery = mkQ [] (locateLHsExprThatReferTo $ spanStart $ toBufSpan definitionLoc) + genericQuery = mkQ [] (locateLHsExprThatReferTo $ spanStart $ toBufSpan rs) 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 + return $ [rs] ++ referrers - 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 + processTokenAsFunParam _ = error "Internal error (unsupported instance of LPat Name)" - return $ tokenIsName `orIfUnknown` tokenIsValBind `orIfUnknown` tokenIsFunParameter `orIfUnknown` tokenIsFunSignature + what <- whatIsAt occFile spn + case what of + ThereIsAnExternalName _ -> error $ "The token is referring to external functionality" + 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 -> -- 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 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] @@ -319,51 +213,4 @@ 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 _ _ _ = [] diff --git a/libhbb.cabal b/libhbb.cabal --- a/libhbb.cabal +++ b/libhbb.cabal @@ -9,7 +9,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.1.1.1 +version: 0.3.0.0 -- A short (one-line) description of the package. synopsis: Backend for text editors to provide better Haskell editing support. @@ -78,7 +78,7 @@ -- Default-Extensions: ConstraintKinds, FlexibleContexts -- Other library packages from which modules are imported. - build-depends: base == 4.* , libhbb >= 0.1, bytestring >= 0.10 + build-depends: base == 4.* , libhbb >= 0.2, bytestring >= 0.10, directory >= 1.2 library exposed-modules: Language.Haskell.HBB.Internal.InternalTTreeCreation diff --git a/src/HBBSimpleCLI.hs b/src/HBBSimpleCLI.hs --- a/src/HBBSimpleCLI.hs +++ b/src/HBBSimpleCLI.hs @@ -11,6 +11,7 @@ import qualified Data.ByteString.Lazy.Char8 as LB import System.Console.GetOpt as O import System.Environment (getArgs) +import System.Directory (getCurrentDirectory) import System.Exit (exitFailure) import System.IO @@ -23,7 +24,7 @@ ,"hbb-simple-cli [-g ghcOpt1 -g ghcOpt2 ...] smart-inline [ ]" ,"hbb-simple-cli [-g ghcOpt1 -g ghcOpt2 ...] occurrences-of [ ...]" ,"hbb-simple-cli [-g ghcOpt1 -g ghcOpt2 ...] exprtype " - ,"hbb-simple-cli applyto [-q] "] + ,"hbb-simple-cli apply-to [-q] "] data OperationMode = ModeInline InlineOptions | ModeSmartInline @@ -42,6 +43,8 @@ main = do programArgs <- getArgs + cwd <- getCurrentDirectory + -- First we want to filter out the options that GHC needs let (ghcOptions,otherArgs) = let optdescr :: [OptDescr String] @@ -50,16 +53,20 @@ (_,_,(_:_)) -> error "Wrong usage of ghc-specific options (every -g must be followed by a GHC option)" (g,o,[] ) -> (g,o) - putApplyToResult :: (String,Maybe String) -> IO () - putApplyToResult (res,Just wa) = hPutStr stderr wa >> putApplyToResult (res,Nothing) - putApplyToResult (res,Nothing) = putStr res + putApplyToResult :: Bool -> (String,Maybe String) -> IO () + putApplyToResult False (res,Just wa) = do hPutStr stderr wa + hPutStrLn stderr "> " + hPutStrLn stderr "> Pass the flag '-q' to suppress this warning!" + putApplyToResult False (res,Nothing) + putApplyToResult True (res,Just wa) = hPutStr stderr wa >> putApplyToResult True (res,Nothing) + putApplyToResult _ (res,Nothing) = putStr res case (ghcOptions,otherArgs) of - (_ ,("occurrences-of":f:l:c:others)) -> occurrencesOf ghcOptions f (BufLoc (read l) (read c)) others >>= putStr . showOccurrencesOfResult + (_ ,("occurrences-of":f:l:c:others)) -> occurrencesOf ghcOptions f (BufLoc (read l) (read c)) others >>= putStr . (showOccurrencesOfResult cwd) (_ ,["exprtype",f,expr]) -> exprtype ghcOptions f expr >>= putStrLn . showExprTypeResult - ([],["applyto" ,"-q",f,str ]) -> applyTo True f str >>= putApplyToResult - ([],["applyto" , f,str ]) -> applyTo False f str >>= putApplyToResult - (_ ,("applyto":_)) -> error "Mode 'applyto' doesn't allow to specify ghc options (with -g)" + ([],["apply-to","-q",f,str ]) -> applyTo True f str >>= putApplyToResult True + ([],["apply-to", f,str ]) -> applyTo False f str >>= putApplyToResult False + (_ ,("apply-to":_)) -> error "Mode 'applyto' doesn't allow to specify ghc options (with -g)" _ -> do (opMode,occFilename,loc1,maybeLoc2) <- do case otherArgs of @@ -83,4 +90,4 @@ case opMode of ModeInline options -> inline ghcOptions options occFilename loc1 maybeLoc2 >>= putStrLn . showInlineResult ModeSmartInline -> smartinline ghcOptions occFilename loc1 maybeLoc2 >>= LB.putStr . showSmartInlineResultAsByteString - ModeLocate -> locate ghcOptions occFilename loc1 >>= putStrLn . showLocateResult + ModeLocate -> locate ghcOptions occFilename loc1 >>= putStrLn . (showLocateResult cwd)