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