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 (createCTagsFileCmd, createETagsFileCmd) where
  11
  12 import GHC
  13 import GhciMonad
  14 import Outputable
  15 import Util
  16
  17 -- ToDo: figure out whether we need these, and put something appropriate
  18 -- into the GHC API instead
  19 import Name (nameOccName)
  20 import OccName (pprOccName)
  21 import MonadUtils
  22
  23 import Data.Maybe
  24 import Panic
  25 import Data.List
  26 import Control.Monad
  27 import System.IO
  28 import System.IO.Error as IO
  29
  30 -----------------------------------------------------------------------------
  31 -- create tags file for currently loaded modules.
  32
  33 createETagsFileCmd, createCTagsFileCmd :: String -> GHCi ()
  34
  35 createCTagsFileCmd ""   = ghciCreateTagsFile CTags "tags"
  36 createCTagsFileCmd file = ghciCreateTagsFile CTags file
  37
  38 createETagsFileCmd ""    = ghciCreateTagsFile ETags "TAGS"
  39 createETagsFileCmd file  = ghciCreateTagsFile ETags file
  40
  41 data TagsKind = ETags | CTags
  42
  43 ghciCreateTagsFile :: TagsKind -> FilePath -> GHCi ()
  44 ghciCreateTagsFile kind file = do
  45   createTagsFile kind file
  46
  47 -- ToDo:
  48 --      - remove restriction that all modules must be interpreted
  49 --        (problem: we don't know source locations for entities unless
  50 --        we compiled the module.
  51 --
  52 --      - extract createTagsFile so it can be used from the command-line
  53 --        (probably need to fix first problem before this is useful).
  54 --
  55 createTagsFile :: TagsKind -> FilePath -> GHCi ()
  56 createTagsFile tagskind tagFile = do
  57   graph <- GHC.getModuleGraph
  58   let ms = map GHC.ms_mod graph
  59       tagModule m = do
  60         is_interpreted <- GHC.moduleIsInterpreted m
  61         -- should we just skip these?
  62         when (not is_interpreted) $
  63           ghcError (CmdLineError ("module '"
  64                                 ++ GHC.moduleNameString (GHC.moduleName m)
  65                                 ++ "' is not interpreted"))
  66         mbModInfo <- GHC.getModuleInfo m
  67         unqual <-
  68           case mbModInfo of
  69              Just minf -> do
  70                 mb_print_unqual <- GHC.mkPrintUnqualifiedForModule minf
  71                 return (fromMaybe GHC.alwaysQualify mb_print_unqual)
  72              Nothing ->
  73                 return GHC.alwaysQualify
  74         case mbModInfo of
  75           Just modInfo -> return $! listTags unqual modInfo
  76           _            -> return []
  77
  78   mtags <- mapM tagModule ms
  79   either_res <- liftIO $ collateAndWriteTags tagskind tagFile $ concat mtags
  80   case either_res of
  81     Left e  -> liftIO $ hPutStrLn stderr $ ioeGetErrorString e
  82     Right _ -> return ()
  83
  84 listTags :: PrintUnqualified -> GHC.ModuleInfo -> [TagInfo]
  85 listTags unqual modInfo =
  86            [ tagInfo unqual name loc
  87            | name <- GHC.modInfoExports modInfo
  88            , let loc = srcSpanStart (nameSrcSpan name)
  89            , isGoodSrcLoc loc
  90            ]
  91
  92 type TagInfo = (String -- tag name
  93                ,String -- file name
  94                ,Int    -- line number
  95                ,Int    -- column number
  96                )
  97
  98 -- get tag info, for later translation into Vim or Emacs style
  99 tagInfo :: PrintUnqualified -> Name -> SrcLoc -> TagInfo
 100 tagInfo unqual name loc
 101     = ( showSDocForUser unqual $ pprOccName (nameOccName name)
 102       , showSDocForUser unqual $ ftext (srcLocFile loc)
 103       , srcLocLine loc
 104       , srcLocCol loc
 105       )
 106
 107 collateAndWriteTags :: TagsKind -> FilePath -> [TagInfo] -> IO (Either IOError ())
 108 collateAndWriteTags CTags file tagInfos = do -- ctags style, Vim et al
 109   let tags = unlines $ sortLe (<=) $ nub $ map showTag tagInfos
 110   IO.try (writeFile file tags)
 111 collateAndWriteTags ETags file tagInfos = do -- etags style, Emacs/XEmacs
 112   let byFile op (_,f1,_,_) (_,f2,_,_) = f1 `op` f2
 113       groups = groupBy (byFile (==)) $ sortLe (byFile (<=)) tagInfos
 114   tagGroups <- mapM tagFileGroup groups
 115   IO.try (writeFile file $ concat tagGroups)
 116   where
 117     tagFileGroup [] = ghcError (CmdLineError "empty tag file group??")
 118     tagFileGroup group@((_,fileName,_,_):_) = do
 119       file <- readFile fileName -- need to get additional info from sources..
 120       let byLine (_,_,l1,_) (_,_,l2,_) = l1 <= l2
 121           sortedGroup = sortLe byLine group
 122           tags = unlines $ perFile sortedGroup 1 0 $ lines file
 123       return $ "\x0c\n" ++ fileName ++ "," ++ show (length tags) ++ "\n" ++ tags
 124     perFile (tagInfo@(_tag, _file, lNo, _colNo):tags) count pos lines@(line:lines')
 125      | lNo >  count = perFile (tagInfo:tags) (count+1) (pos+length line) lines'
 126      | lNo == count = showETag tagInfo line pos : perFile tags count pos lines
 127     perFile _ _ _ _ = []
 128
 129 -- simple ctags format, for Vim et al
 130 showTag :: TagInfo -> String
 131 showTag (tag, file, lineNo, _colNo)
 132     =  tag ++ "\t" ++ file ++ "\t" ++ show lineNo
 133
 134 -- etags format, for Emacs/XEmacs
 135 showETag :: TagInfo -> String -> Int -> String
 136 showETag (tag, _file, lineNo, colNo) line charPos
 137     =  take colNo line ++ tag
 138     ++ "\x7f" ++ tag
 139     ++ "\x01" ++ show lineNo
 140     ++ "," ++ show charPos
 141