libhbb 0.1.1.0 → 0.1.1.1
raw patch · 6 files changed
+93/−34 lines, 6 filesdep +directory
Dependencies added: directory
Files
- Language/Haskell/HBB/ExprType.hs +1/−0
- Language/Haskell/HBB/Internal/AST.hs +8/−8
- Language/Haskell/HBB/Internal/TTreeJSON.hs +2/−1
- Language/Haskell/HBB/OccurrencesOf.hs +76/−21
- Language/Haskell/HBB/SmartInline.hs +3/−2
- libhbb.cabal +3/−2
Language/Haskell/HBB/ExprType.hs view
@@ -52,3 +52,4 @@ flgs <- getSessionDynFlags let tyStr = showSDocForUser flgs neverQualify (pprParendType $ ty) return (ty,tyStr)+
Language/Haskell/HBB/Internal/AST.hs view
@@ -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'
Language/Haskell/HBB/Internal/TTreeJSON.hs view
@@ -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
Language/Haskell/HBB/OccurrencesOf.hs view
@@ -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 _ _ _ = []
Language/Haskell/HBB/SmartInline.hs view
@@ -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
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.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