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