compiler/ghci/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
  21 import Data.Maybe
  22 import Control.Exception
  23 import Data.List
  24 import Control.Monad
  25 import System.IO
  26 import System.IO.Error as IO
  27
  28 -----------------------------------------------------------------------------
  29 -- create tags file for currently loaded modules.
  30
  31 createETagsFileCmd, createCTagsFileCmd :: String -> GHCi ()
  32
  33 createCTagsFileCmd ""   = ghciCreateTagsFile CTags "tags"
  34 createCTagsFileCmd file = ghciCreateTagsFile CTags file
  35
  36 createETagsFileCmd ""    = ghciCreateTagsFile ETags "TAGS"
  37 createETagsFileCmd file  = ghciCreateTagsFile ETags file
  38
  39 data TagsKind = ETags | CTags
  40
  41 ghciCreateTagsFile :: TagsKind -> FilePath -> GHCi ()
  42 ghciCreateTagsFile kind file = do
  43   session <- getSession
  44   io $ createTagsFile session 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 :: Session -> TagsKind -> FilePath -> IO ()
  55 createTagsFile session tagskind tagFile = do
  56   graph <- GHC.getModuleGraph session
  57   let ms = map GHC.ms_mod graph
  58       tagModule m = do
  59         is_interpreted <- GHC.moduleIsInterpreted session m
  60         -- should we just skip these?
  61         when (not is_interpreted) $
  62           throwDyn (CmdLineError ("module '"
  63                                 ++ GHC.moduleNameString (GHC.moduleName m)
  64                                 ++ "' is not interpreted"))
  65         mbModInfo <- GHC.getModuleInfo session m
  66         unqual <-
  67           case mbModInfo of
  68              Just minf -> do
  69                 mb_print_unqual <- GHC.mkPrintUnqualifiedForModule session 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 <- collateAndWriteTags tagskind tagFile $ concat mtags
  79   case either_res of
  80     Left e  -> 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 [] = throwDyn (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 (line:lines)
 124      | lNo > count =
 125       perFile (tagInfo:tags) (count+1) (pos+length line) lines
 126     perFile (tagInfo@(_tag, _file, lNo, _colNo):tags) count pos lines@(line:_)
 127      | lNo == count =
 128       showETag tagInfo line pos : perFile tags count pos lines
 129     perFile _ _ _ _ = []
 130
 131 -- simple ctags format, for Vim et al
 132 showTag :: TagInfo -> String
 133 showTag (tag, file, lineNo, _colNo)
 134     =  tag ++ "\t" ++ file ++ "\t" ++ show lineNo
 135
 136 -- etags format, for Emacs/XEmacs
 137 showETag :: TagInfo -> String -> Int -> String
 138 showETag (tag, _file, lineNo, colNo) line charPos
 139     =  take colNo line ++ tag
 140     ++ "\x7f" ++ tag
 141     ++ "\x01" ++ show lineNo
 142     ++ "," ++ show charPos
 143