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