libhbb 0.1.1.1 → 0.3.0.0
raw patch · 9 files changed
+292/−252 lines, 9 filesdep ~libhbb
Dependency ranges changed: libhbb
Files
- Language/Haskell/HBB/ApplyTo.hs +3/−5
- Language/Haskell/HBB/Internal/GHC.hs +0/−7
- Language/Haskell/HBB/Internal/GHCHighlevel.hs +194/−24
- Language/Haskell/HBB/Internal/Lexer.hs +4/−4
- Language/Haskell/HBB/Internal/SrcSpan.hs +25/−0
- Language/Haskell/HBB/Locate.hs +5/−5
- Language/Haskell/HBB/OccurrencesOf.hs +43/−196
- libhbb.cabal +2/−2
- src/HBBSimpleCLI.hs +16/−9
Language/Haskell/HBB/ApplyTo.hs view
@@ -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
Language/Haskell/HBB/Internal/GHC.hs view
@@ -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)
Language/Haskell/HBB/Internal/GHCHighlevel.hs view
@@ -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 _ _ = []
Language/Haskell/HBB/Internal/Lexer.hs view
@@ -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
Language/Haskell/HBB/Internal/SrcSpan.hs view
@@ -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. --
Language/Haskell/HBB/Locate.hs view
@@ -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.
Language/Haskell/HBB/OccurrencesOf.hs view
@@ -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 _ _ _ = []
libhbb.cabal view
@@ -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
src/HBBSimpleCLI.hs view
@@ -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 <filename> <line> <column> [<line> <column>]" ,"hbb-simple-cli [-g ghcOpt1 -g ghcOpt2 ...] occurrences-of <filename> <line> <column> [<filename> ...]" ,"hbb-simple-cli [-g ghcOpt1 -g ghcOpt2 ...] exprtype <filename> <expression>"- ,"hbb-simple-cli applyto [-q] <function of type string to string> <string>"]+ ,"hbb-simple-cli apply-to [-q] <function of type string to string> <string>"] 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)