diff --git a/Language/Haskell/HBB/ExprType.hs b/Language/Haskell/HBB/ExprType.hs --- a/Language/Haskell/HBB/ExprType.hs +++ b/Language/Haskell/HBB/ExprType.hs @@ -52,3 +52,4 @@ flgs <- getSessionDynFlags let tyStr = showSDocForUser flgs neverQualify (pprParendType $ ty) return (ty,tyStr) + diff --git a/Language/Haskell/HBB/Internal/AST.hs b/Language/Haskell/HBB/Internal/AST.hs --- a/Language/Haskell/HBB/Internal/AST.hs +++ b/Language/Haskell/HBB/Internal/AST.hs @@ -9,7 +9,7 @@ import NameSet (NameSet) import GHC --- This function is similar to 'everythingBut' from the SYB schemes but uses a +-- | This function is similar to 'everythingBut' from the SYB schemes but uses a -- neutral element and automatically omits elements of the renamed AST that -- mustn't be evaluated. queryRenamedAST :: r -> (r -> r -> r) -> GenericQ r -> GenericQ r @@ -20,16 +20,16 @@ isPostTcType = (const False) `extQ` ((const True) :: PostTcType -> Bool) --- Uses SYB to create generic transformation that omits elements of type --- 'PostTcType'. This is needed because after the renamer 'PostTcTypes' must --- not be evaluated. +-- | Uses SYB to create generic transformation that omits elements of type +-- 'PostTcType'. This is needed because after the renamer 'PostTcTypes' must not +-- be evaluated. transformRenamedAST :: (Monad m, Data a) => GenericM m -> a -> m a transformRenamedAST = everywhereButM isPostTcType where isPostTcType :: GenericQ Bool isPostTcType = extQ (const False) ((const True) :: PostTcType -> Bool) --- Uses SYB to create generic transformation that omits elements of type +-- | Uses SYB to create generic transformation that omits elements of type -- 'NameSet'. This is needed because after the renamer 'NameSet' (the element -- 'bind_fvs' in function bindings) must not be evaluated. transformTypecheckedAST :: (Monad m, Data a) => GenericM m -> a -> m a @@ -38,9 +38,9 @@ isNameSet :: GenericQ Bool isNameSet = extQ (const False) ((const True) :: NameSet -> Bool) --- The default traversal functions of the SYB package lack a generic monadic --- transformation where certain cases can be excluded. We want this case --- because we want to use the Writer Monad and certain cases that should not be +-- | The default traversal functions of the SYB package lack a generic monadic +-- transformation where certain cases can be excluded. We want this case because +-- we want to use the Writer Monad and certain cases that should not be -- evaluated must be omitted. everywhereButM :: Monad m => GenericQ Bool -> GenericM m -> GenericM m everywhereButM shouldExclude f x | (not . shouldExclude) x = do x' <- f x; gmapM (everywhereButM shouldExclude f) x' diff --git a/Language/Haskell/HBB/Internal/TTreeJSON.hs b/Language/Haskell/HBB/Internal/TTreeJSON.hs --- a/Language/Haskell/HBB/Internal/TTreeJSON.hs +++ b/Language/Haskell/HBB/Internal/TTreeJSON.hs @@ -32,7 +32,8 @@ -- spans of the source code. It is used at this point to avoid the introduction -- of (some) user-defined types to describe the transformation tree. --- This is the (exported) function that allows the deserialization from JSON. +-- | This is the function that allows the deserialization of the +-- Transformation-Tree from JSON. decodeTTreeFromJSON :: StrictByteString.ByteString -> Either String (RealSrcSpan,TTree LineBuf (RealSrcSpan,Int) BufSpan) decodeTTreeFromJSON bs = case eitherDecodeStrict' bs of Right (JSON_RootTTree tree) -> Right tree 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 @@ -13,7 +13,8 @@ import Language.Haskell.HBB.Internal.Lexer import Language.Haskell.HBB.Internal.GHC import Language.Haskell.HBB.Internal.AST -import System.FilePath (normalise) +import System.Directory (getCurrentDirectory) +import System.FilePath (normalise,makeRelative) import Control.Monad (foldM) import Data.Generics import FastString (unpackFS,fsLit) @@ -26,16 +27,40 @@ import Name import GHC -occurrencesOf :: [String] -> FilePath -> BufLoc -> [FilePath] -> IO [(FilePath,BufSpan)] +-- +-- This file deals with the renaming of names that point to bindings (value and +-- 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. +occurrencesOf + :: [String] -- ^ A list of ghc options (e.g. @["-isrc"]@) + -> FilePath -- ^ The file where the token to rename resides in + -> BufLoc -- ^ The location where the token to rename is + -> [FilePath] -- ^ A list of further files which possibly contain this token and + -- which should be searched for it + -> IO [(FilePath,BufSpan)] occurrencesOf ghcOptions filename reqLoc otherFiles = runGhcWithCmdLineFlags ghcOptions (Just libdir) $ occurrencesOfM filename reqLoc otherFiles +-- | This is the monadic version of occurrencesOf which allows to use this mode +-- of operation from a preconfigured GHC environment. occurrencesOfM :: GhcMonad m => FilePath -> BufLoc -> [FilePath] -> m [(FilePath,BufSpan)] occurrencesOfM occFile' loc otherFiles' = do + + cwd <- liftIO $ getCurrentDirectory + -- We normalize the filenames to be able to use 'union' from -- 'Data.List' to merge them. - let occFile = normalise occFile' - otherFiles = map normalise otherFiles' + let occFile = (relativeAndNormalisedPath cwd) occFile' + otherFiles = map (relativeAndNormalisedPath cwd) otherFiles' resLocs <- do @@ -47,13 +72,15 @@ Left LexingFailed -> error "Lexing failed. The source code seems to contain errors." Right (_,rSpn) -> toBufSpan rSpn - processToken occFile spanIdentifiedByLexer otherFiles + processToken cwd occFile spanIdentifiedByLexer otherFiles let convertResult :: RealSrcSpan -> (FilePath,BufSpan) convertResult r = (unpackFS $ srcSpanFile r,toBufSpan r) return $ map (\x -> convertResult x) resLocs +-- | This Function formats the results from the occurrencesOf or occurrencesOfM +-- function. showOccurrencesOfResult :: [(FilePath,BufSpan)] -> String showOccurrencesOfResult elems = sOORAcc [] elems where @@ -64,10 +91,8 @@ -- | 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 -> BufSpan -> [FilePath] -> m [RealSrcSpan] -processToken occFile spn@(BufSpan (BufLoc _ c1) (BufLoc _ c2)) otherFiles = do - - what <- whatIsAt occFile spn +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 @@ -77,7 +102,7 @@ bindingFile = let ((L l _),_) = result funBindInfo in case srcSpanFileName_maybe l of Nothing -> [] - Just fs -> [normalise $ unpackFS fs] + Just fs -> [relativeAndNormalisedPath cwd $ unpackFS fs] referrers <- foldM (accumulateThingsThatRefer (name funBindInfo)) @@ -87,7 +112,7 @@ 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 (c2 - c1) b + (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." @@ -142,11 +167,14 @@ 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. @@ -155,8 +183,13 @@ -- | This function is responsible to detect what kind of thing is located at -- the passed src-span (the token). -whatIsAt :: GhcMonad m => FilePath -> BufSpan -> m WhatIsAtResult -whatIsAt filename (BufSpan startLoc@(BufLoc _ c1) (BufLoc _ c2)) = do +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 @@ -172,7 +205,7 @@ tokenIsValBind <- do let considerBindsAt :: LHsBindLR Name Name -> BufLoc -> Maybe BufSpan considerBindsAt (L (RealSrcSpan r) b@(FunBind {})) bl = - let allSpansOfThisBinding = realSrcSpansOfBinding (c2 - c1) b + let allSpansOfThisBinding = realSrcSpansOfBinding cwd (c2 - c1) b foldArg :: Bool -> RealSrcSpan -> Bool foldArg True _ = True @@ -198,14 +231,34 @@ things <- getThingsAt considerLPat filename startLoc case things of [(L _ (VarPat n))] -> return $ ThereIsAFunParameter n - _ -> return $ UnknownElement + _ -> 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 + + 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 - return $ tokenIsName `orIfUnknown` tokenIsValBind `orIfUnknown` tokenIsFunParameter + return $ tokenIsName `orIfUnknown` tokenIsValBind `orIfUnknown` tokenIsFunParameter `orIfUnknown` tokenIsFunSignature -- | This function searches the passed file for variables, import- or export- -- declarations that refer to the name passed as first parameter. @@ -279,19 +332,21 @@ -- | 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 - :: Int -- ^ Length of the function name (determined by the lexer) + :: 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 funNameLen (FunBind { fun_infix = False - , fun_matches = (MatchGroup lmatches _) }) = +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 @@ -304,11 +359,11 @@ let sta = realSrcSpanStart l (sl,sc) = (srcLocLine sta,srcLocCol sta) -- We extract the file name to be able to normalise it - f = fsLit $ normalise $ unpackFS $ srcLocFile sta + 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 _ _ = [] +realSrcSpansOfBinding _ _ _ = [] diff --git a/Language/Haskell/HBB/SmartInline.hs b/Language/Haskell/HBB/SmartInline.hs --- a/Language/Haskell/HBB/SmartInline.hs +++ b/Language/Haskell/HBB/SmartInline.hs @@ -10,13 +10,14 @@ RealSrcSpan(..), TTree(..), LineBuf, - encodeTTreeToJSON + encodeTTreeToJSON, + decodeTTreeFromJSON ) where import Language.Haskell.HBB.Internal.InternalTTreeCreation import Language.Haskell.HBB.Internal.InternalTTree import Language.Haskell.HBB.Internal.GHCHighlevel -import Language.Haskell.HBB.Internal.TTreeJSON (encodeTTreeToJSON) +import Language.Haskell.HBB.Internal.TTreeJSON (encodeTTreeToJSON,decodeTTreeFromJSON) import Language.Haskell.HBB.Internal.SrcSpan import Language.Haskell.HBB.Internal.TTree import Language.Haskell.HBB.Internal.GHC 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.0 +version: 0.1.1.1 -- A short (one-line) description of the package. synopsis: Backend for text editors to provide better Haskell editing support. @@ -113,7 +113,8 @@ bytestring >= 0.10, time >= 1.4, process >= 1.1, - filepath >= 1.3 + filepath >= 1.3, + directory >= 1.2 Test-Suite spec Main-Is: Main.hs