ghc/GhciTags.hs

   1 -----------------------------------------------------------------------------
   2 --
   3 -- GHCi's :ctags and :etags commands
   4 --
   5 -- (c) The GHC Team 2005-2007
   6 --
   7 -----------------------------------------------------------------------------
   8
   9 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
  10 module GhciTags (
  11   createCTagsWithLineNumbersCmd,
  12   createCTagsWithRegExesCmd,
  13   createETagsFileCmd
  14 ) where
  15
  16 import Exception
  17 import GHC
  18 import GhciMonad
  19 import Outputable
  20 import Util
  21 import SrcLoc
  22
  23 -- ToDo: figure out whether we need these, and put something appropriate
  24 -- into the GHC API instead
  25 import Name (nameOccName)
  26 import OccName (pprOccName)
  27 import MonadUtils
  28
  29 import Data.Maybe
  30 import Panic
  31 import Data.List
  32 import Control.Monad
  33 import System.IO
  34 import System.IO.Error
  35
  36 -----------------------------------------------------------------------------
  37 -- create tags file for currently loaded modules.
  38
  39 createCTagsWithLineNumbersCmd, createCTagsWithRegExesCmd,
  40   createETagsFileCmd :: String -> GHCi ()
  41
  42 createCTagsWithLineNumbersCmd ""   =
  43   ghciCreateTagsFile CTagsWithLineNumbers "tags"
  44 createCTagsWithLineNumbersCmd file =
  45   ghciCreateTagsFile CTagsWithLineNumbers file
  46
  47 createCTagsWithRegExesCmd ""   =
  48   ghciCreateTagsFile CTagsWithRegExes "tags"
  49 createCTagsWithRegExesCmd file =
  50   ghciCreateTagsFile CTagsWithRegExes file
  51
  52 createETagsFileCmd ""    = ghciCreateTagsFile ETags "TAGS"
  53 createETagsFileCmd file  = ghciCreateTagsFile ETags file
  54
  55 data TagsKind = ETags | CTagsWithLineNumbers | CTagsWithRegExes
  56
  57 ghciCreateTagsFile :: TagsKind -> FilePath -> GHCi ()
  58 ghciCreateTagsFile kind file = do
  59   createTagsFile kind file
  60
  61 -- ToDo:
  62 --      - remove restriction that all modules must be interpreted
  63 --        (problem: we don't know source locations for entities unless
  64 --        we compiled the module.
  65 --
  66 --      - extract createTagsFile so it can be used from the command-line
  67 --        (probably need to fix first problem before this is useful).
  68 --
  69 createTagsFile :: TagsKind -> FilePath -> GHCi ()
  70 createTagsFile tagskind tagsFile = do
  71   graph <- GHC.getModuleGraph
  72   mtags <- mapM listModuleTags (map GHC.ms_mod graph)
  73   either_res <- liftIO $ collateAndWriteTags tagskind tagsFile $ concat mtags
  74   case either_res of
  75     Left e  -> liftIO $ hPutStrLn stderr $ ioeGetErrorString e
  76     Right _ -> return ()
  77
  78
  79 listModuleTags :: GHC.Module -> GHCi [TagInfo]
  80 listModuleTags m = do
  81   is_interpreted <- GHC.moduleIsInterpreted m
  82   -- should we just skip these?
  83   when (not is_interpreted) $
  84     let mName = GHC.moduleNameString (GHC.moduleName m) in
  85     ghcError (CmdLineError ("module '" ++ mName ++ "' is not interpreted"))
  86   mbModInfo <- GHC.getModuleInfo m
  87   case mbModInfo of
  88     Nothing -> return []
  89     Just mInfo -> do
  90        mb_print_unqual <- GHC.mkPrintUnqualifiedForModule mInfo
  91        let unqual = fromMaybe GHC.alwaysQualify mb_print_unqual
  92        let names = fromMaybe [] $GHC.modInfoTopLevelScope mInfo
  93        let localNames = filter ((m==) . nameModule) names
  94        mbTyThings <- mapM GHC.lookupName localNames
  95        return $! [ tagInfo unqual exported kind name realLoc
  96                      | tyThing <- catMaybes mbTyThings
  97                      , let name = getName tyThing
  98                      , let exported = GHC.modInfoIsExportedName mInfo name
  99                      , let kind = tyThing2TagKind tyThing
 100                      , let loc = srcSpanStart (nameSrcSpan name)
 101                      , RealSrcLoc realLoc <- [loc]
 102                      ]
 103
 104   where
 105     tyThing2TagKind (AnId _)     = 'v'
 106     tyThing2TagKind (ADataCon _) = 'd'
 107     tyThing2TagKind (ATyCon _)   = 't'
 108     tyThing2TagKind (AClass _)   = 'c'
 109     tyThing2TagKind (ACoAxiom _) = 'x'
 110
 111
 112 data TagInfo = TagInfo
 113   { tagExported :: Bool -- is tag exported
 114   , tagKind :: Char   -- tag kind
 115   , tagName :: String -- tag name
 116   , tagFile :: String -- file name
 117   , tagLine :: Int    -- line number
 118   , tagCol :: Int     -- column number
 119   , tagSrcInfo :: Maybe (String,Integer)  -- source code line and char offset
 120   }
 121
 122
 123 -- get tag info, for later translation into Vim or Emacs style
 124 tagInfo :: PrintUnqualified -> Bool -> Char -> Name -> RealSrcLoc -> TagInfo
 125 tagInfo unqual exported kind name loc
 126     = TagInfo exported kind
 127         (showSDocForUser unqual $ pprOccName (nameOccName name))
 128         (showSDocForUser unqual $ ftext (srcLocFile loc))
 129         (srcLocLine loc) (srcLocCol loc) Nothing
 130
 131
 132 collateAndWriteTags :: TagsKind -> FilePath -> [TagInfo] -> IO (Either IOError ())
 133 -- ctags style with the Ex exresion being just the line number, Vim et al
 134 collateAndWriteTags CTagsWithLineNumbers file tagInfos = do
 135   let tags = unlines $ sortLe (<=) $ map showCTag tagInfos
 136   tryIO (writeFile file tags)
 137
 138 -- ctags style with the Ex exresion being a regex searching the line, Vim et al
 139 collateAndWriteTags CTagsWithRegExes file tagInfos = do -- ctags style, Vim et al
 140   tagInfoGroups <- makeTagGroupsWithSrcInfo tagInfos
 141   let tags = unlines $ sortLe (<=) $ map showCTag $concat tagInfoGroups
 142   tryIO (writeFile file tags)
 143
 144 collateAndWriteTags ETags file tagInfos = do -- etags style, Emacs/XEmacs
 145   tagInfoGroups <- makeTagGroupsWithSrcInfo $filter tagExported tagInfos
 146   let tagGroups = map processGroup tagInfoGroups
 147   tryIO (writeFile file $ concat tagGroups)
 148
 149   where
 150     processGroup [] = ghcError (CmdLineError "empty tag file group??")
 151     processGroup group@(tagInfo:_) =
 152       let tags = unlines $ map showETag group in
 153       "\x0c\n" ++ tagFile tagInfo ++ "," ++ show (length tags) ++ "\n" ++ tags
 154
 155
 156 makeTagGroupsWithSrcInfo :: [TagInfo] -> IO [[TagInfo]]
 157 makeTagGroupsWithSrcInfo tagInfos = do
 158   let byFile op ti0 ti1 = tagFile ti0 `op` tagFile ti1
 159       groups = groupBy (byFile (==)) $ sortLe (byFile (<=)) tagInfos
 160   mapM addTagSrcInfo groups
 161
 162   where
 163     addTagSrcInfo [] = ghcError (CmdLineError "empty tag file group??")
 164     addTagSrcInfo group@(tagInfo:_) = do
 165       file <- readFile $tagFile tagInfo
 166       let byLine ti0 ti1 = tagLine ti0 <= tagLine ti1
 167           sortedGroup = sortLe byLine group
 168       return $ perFile sortedGroup 1 0 $ lines file
 169
 170     perFile allTags@(tag:tags) cnt pos allLs@(l:ls)
 171      | tagLine tag > cnt =
 172          perFile allTags (cnt+1) (pos+fromIntegral(length l)) ls
 173      | tagLine tag == cnt =
 174          tag{ tagSrcInfo = Just(l,pos) } : perFile tags cnt pos allLs
 175     perFile _ _ _ _ = []
 176
 177
 178 -- ctags format, for Vim et al
 179 showCTag :: TagInfo -> String
 180 showCTag ti =
 181   tagName ti ++ "\t" ++ tagFile ti ++ "\t" ++ tagCmd ++ ";\"\t" ++
 182     tagKind ti : ( if tagExported ti then "" else "\tfile:" )
 183
 184   where
 185     tagCmd =
 186       case tagSrcInfo ti of
 187         Nothing -> show $tagLine ti
 188         Just (srcLine,_) -> "/^"++ foldr escapeSlashes [] srcLine ++"$/"
 189
 190       where
 191         escapeSlashes '/' r = '\\' : '/' : r
 192         escapeSlashes '\\' r = '\\' : '\\' : r
 193         escapeSlashes c r = c : r
 194
 195
 196 -- etags format, for Emacs/XEmacs
 197 showETag :: TagInfo -> String
 198 showETag TagInfo{ tagName = tag, tagLine = lineNo, tagCol = colNo,
 199                   tagSrcInfo = Just (srcLine,charPos) }
 200     =  take colNo srcLine ++ tag
 201     ++ "\x7f" ++ tag
 202     ++ "\x01" ++ show lineNo
 203     ++ "," ++ show charPos
 204 showETag _ = ghcError (CmdLineError "missing source file info in showETag")
 205