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