ghc/GhciTags.hs

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