X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=ghc%2FGhciTags.hs;h=ffec5be64dc26c907d39125a641dde6bdacd4539;hp=b53a56f967db5136b618bbd48e39ddfe6a1a1849;hb=b2bd63f99d643f6b3eb30bb72bb9ae26d4183252;hpb=46aed8a4a084add708bbd119d19905105d5f0d72 diff --git a/ghc/GhciTags.hs b/ghc/GhciTags.hs index b53a56f..ffec5be 100644 --- a/ghc/GhciTags.hs +++ b/ghc/GhciTags.hs @@ -6,12 +6,19 @@ -- ----------------------------------------------------------------------------- -module GhciTags (createCTagsFileCmd, createETagsFileCmd) where - +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +module GhciTags ( + createCTagsWithLineNumbersCmd, + createCTagsWithRegExesCmd, + createETagsFileCmd +) where + +import Exception import GHC import GhciMonad import Outputable import Util +import SrcLoc -- ToDo: figure out whether we need these, and put something appropriate -- into the GHC API instead @@ -24,20 +31,28 @@ import Panic import Data.List import Control.Monad import System.IO -import System.IO.Error as IO +import System.IO.Error ----------------------------------------------------------------------------- -- create tags file for currently loaded modules. -createETagsFileCmd, createCTagsFileCmd :: String -> GHCi () +createCTagsWithLineNumbersCmd, createCTagsWithRegExesCmd, + createETagsFileCmd :: String -> GHCi () + +createCTagsWithLineNumbersCmd "" = + ghciCreateTagsFile CTagsWithLineNumbers "tags" +createCTagsWithLineNumbersCmd file = + ghciCreateTagsFile CTagsWithLineNumbers file -createCTagsFileCmd "" = ghciCreateTagsFile CTags "tags" -createCTagsFileCmd file = ghciCreateTagsFile CTags file +createCTagsWithRegExesCmd "" = + ghciCreateTagsFile CTagsWithRegExes "tags" +createCTagsWithRegExesCmd file = + ghciCreateTagsFile CTagsWithRegExes file createETagsFileCmd "" = ghciCreateTagsFile ETags "TAGS" createETagsFileCmd file = ghciCreateTagsFile ETags file -data TagsKind = ETags | CTags +data TagsKind = ETags | CTagsWithLineNumbers | CTagsWithRegExes ghciCreateTagsFile :: TagsKind -> FilePath -> GHCi () ghciCreateTagsFile kind file = do @@ -52,89 +67,139 @@ ghciCreateTagsFile kind file = do -- (probably need to fix first problem before this is useful). -- createTagsFile :: TagsKind -> FilePath -> GHCi () -createTagsFile tagskind tagFile = do +createTagsFile tagskind tagsFile = do graph <- GHC.getModuleGraph - let ms = map GHC.ms_mod graph - tagModule m = do - is_interpreted <- GHC.moduleIsInterpreted m - -- should we just skip these? - when (not is_interpreted) $ - ghcError (CmdLineError ("module '" - ++ GHC.moduleNameString (GHC.moduleName m) - ++ "' is not interpreted")) - mbModInfo <- GHC.getModuleInfo m - unqual <- - case mbModInfo of - Just minf -> do - mb_print_unqual <- GHC.mkPrintUnqualifiedForModule minf - return (fromMaybe GHC.alwaysQualify mb_print_unqual) - Nothing -> - return GHC.alwaysQualify - case mbModInfo of - Just modInfo -> return $! listTags unqual modInfo - _ -> return [] - - mtags <- mapM tagModule ms - either_res <- liftIO $ collateAndWriteTags tagskind tagFile $ concat mtags + mtags <- mapM listModuleTags (map GHC.ms_mod graph) + either_res <- liftIO $ collateAndWriteTags tagskind tagsFile $ concat mtags case either_res of Left e -> liftIO $ hPutStrLn stderr $ ioeGetErrorString e Right _ -> return () -listTags :: PrintUnqualified -> GHC.ModuleInfo -> [TagInfo] -listTags unqual modInfo = - [ tagInfo unqual name loc - | name <- GHC.modInfoExports modInfo - , let loc = srcSpanStart (nameSrcSpan name) - , isGoodSrcLoc loc - ] -type TagInfo = (String -- tag name - ,String -- file name - ,Int -- line number - ,Int -- column number - ) +listModuleTags :: GHC.Module -> GHCi [TagInfo] +listModuleTags m = do + is_interpreted <- GHC.moduleIsInterpreted m + -- should we just skip these? + when (not is_interpreted) $ + let mName = GHC.moduleNameString (GHC.moduleName m) in + ghcError (CmdLineError ("module '" ++ mName ++ "' is not interpreted")) + mbModInfo <- GHC.getModuleInfo m + case mbModInfo of + Nothing -> return [] + Just mInfo -> do + mb_print_unqual <- GHC.mkPrintUnqualifiedForModule mInfo + let unqual = fromMaybe GHC.alwaysQualify mb_print_unqual + let names = fromMaybe [] $GHC.modInfoTopLevelScope mInfo + let localNames = filter ((m==) . nameModule) names + mbTyThings <- mapM GHC.lookupName localNames + return $! [ tagInfo unqual exported kind name realLoc + | tyThing <- catMaybes mbTyThings + , let name = getName tyThing + , let exported = GHC.modInfoIsExportedName mInfo name + , let kind = tyThing2TagKind tyThing + , let loc = srcSpanStart (nameSrcSpan name) + , RealSrcLoc realLoc <- [loc] + ] + + where + tyThing2TagKind (AnId _) = 'v' + tyThing2TagKind (ADataCon _) = 'd' + tyThing2TagKind (ATyCon _) = 't' + tyThing2TagKind (AClass _) = 'c' + tyThing2TagKind (ACoAxiom _) = 'x' + + +data TagInfo = TagInfo + { tagExported :: Bool -- is tag exported + , tagKind :: Char -- tag kind + , tagName :: String -- tag name + , tagFile :: String -- file name + , tagLine :: Int -- line number + , tagCol :: Int -- column number + , tagSrcInfo :: Maybe (String,Integer) -- source code line and char offset + } + -- get tag info, for later translation into Vim or Emacs style -tagInfo :: PrintUnqualified -> Name -> SrcLoc -> TagInfo -tagInfo unqual name loc - = ( showSDocForUser unqual $ pprOccName (nameOccName name) - , showSDocForUser unqual $ ftext (srcLocFile loc) - , srcLocLine loc - , srcLocCol loc - ) +tagInfo :: PrintUnqualified -> Bool -> Char -> Name -> RealSrcLoc -> TagInfo +tagInfo unqual exported kind name loc + = TagInfo exported kind + (showSDocForUser unqual $ pprOccName (nameOccName name)) + (showSDocForUser unqual $ ftext (srcLocFile loc)) + (srcLocLine loc) (srcLocCol loc) Nothing + collateAndWriteTags :: TagsKind -> FilePath -> [TagInfo] -> IO (Either IOError ()) -collateAndWriteTags CTags file tagInfos = do -- ctags style, Vim et al - let tags = unlines $ sortLe (<=) $ nub $ map showTag tagInfos - IO.try (writeFile file tags) +-- ctags style with the Ex exresion being just the line number, Vim et al +collateAndWriteTags CTagsWithLineNumbers file tagInfos = do + let tags = unlines $ sortLe (<=) $ map showCTag tagInfos + tryIO (writeFile file tags) + +-- ctags style with the Ex exresion being a regex searching the line, Vim et al +collateAndWriteTags CTagsWithRegExes file tagInfos = do -- ctags style, Vim et al + tagInfoGroups <- makeTagGroupsWithSrcInfo tagInfos + let tags = unlines $ sortLe (<=) $ map showCTag $concat tagInfoGroups + tryIO (writeFile file tags) + collateAndWriteTags ETags file tagInfos = do -- etags style, Emacs/XEmacs - let byFile op (_,f1,_,_) (_,f2,_,_) = f1 `op` f2 + tagInfoGroups <- makeTagGroupsWithSrcInfo $filter tagExported tagInfos + let tagGroups = map processGroup tagInfoGroups + tryIO (writeFile file $ concat tagGroups) + + where + processGroup [] = ghcError (CmdLineError "empty tag file group??") + processGroup group@(tagInfo:_) = + let tags = unlines $ map showETag group in + "\x0c\n" ++ tagFile tagInfo ++ "," ++ show (length tags) ++ "\n" ++ tags + + +makeTagGroupsWithSrcInfo :: [TagInfo] -> IO [[TagInfo]] +makeTagGroupsWithSrcInfo tagInfos = do + let byFile op ti0 ti1 = tagFile ti0 `op` tagFile ti1 groups = groupBy (byFile (==)) $ sortLe (byFile (<=)) tagInfos - tagGroups <- mapM tagFileGroup groups - IO.try (writeFile file $ concat tagGroups) + mapM addTagSrcInfo groups + where - tagFileGroup [] = ghcError (CmdLineError "empty tag file group??") - tagFileGroup group@((_,fileName,_,_):_) = do - file <- readFile fileName -- need to get additional info from sources.. - let byLine (_,_,l1,_) (_,_,l2,_) = l1 <= l2 + addTagSrcInfo [] = ghcError (CmdLineError "empty tag file group??") + addTagSrcInfo group@(tagInfo:_) = do + file <- readFile $tagFile tagInfo + let byLine ti0 ti1 = tagLine ti0 <= tagLine ti1 sortedGroup = sortLe byLine group - tags = unlines $ perFile sortedGroup 1 0 $ lines file - return $ "\x0c\n" ++ fileName ++ "," ++ show (length tags) ++ "\n" ++ tags - perFile (tagInfo@(_tag, _file, lNo, _colNo):tags) count pos lines@(line:lines') - | lNo > count = perFile (tagInfo:tags) (count+1) (pos+length line) lines' - | lNo == count = showETag tagInfo line pos : perFile tags count pos lines + return $ perFile sortedGroup 1 0 $ lines file + + perFile allTags@(tag:tags) cnt pos allLs@(l:ls) + | tagLine tag > cnt = + perFile allTags (cnt+1) (pos+fromIntegral(length l)) ls + | tagLine tag == cnt = + tag{ tagSrcInfo = Just(l,pos) } : perFile tags cnt pos allLs perFile _ _ _ _ = [] --- simple ctags format, for Vim et al -showTag :: TagInfo -> String -showTag (tag, file, lineNo, _colNo) - = tag ++ "\t" ++ file ++ "\t" ++ show lineNo + +-- ctags format, for Vim et al +showCTag :: TagInfo -> String +showCTag ti = + tagName ti ++ "\t" ++ tagFile ti ++ "\t" ++ tagCmd ++ ";\"\t" ++ + tagKind ti : ( if tagExported ti then "" else "\tfile:" ) + + where + tagCmd = + case tagSrcInfo ti of + Nothing -> show $tagLine ti + Just (srcLine,_) -> "/^"++ foldr escapeSlashes [] srcLine ++"$/" + + where + escapeSlashes '/' r = '\\' : '/' : r + escapeSlashes '\\' r = '\\' : '\\' : r + escapeSlashes c r = c : r + -- etags format, for Emacs/XEmacs -showETag :: TagInfo -> String -> Int -> String -showETag (tag, _file, lineNo, colNo) line charPos - = take colNo line ++ tag +showETag :: TagInfo -> String +showETag TagInfo{ tagName = tag, tagLine = lineNo, tagCol = colNo, + tagSrcInfo = Just (srcLine,charPos) } + = take colNo srcLine ++ tag ++ "\x7f" ++ tag ++ "\x01" ++ show lineNo ++ "," ++ show charPos +showETag _ = ghcError (CmdLineError "missing source file info in showETag")