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