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