Merge branch 'master' of http://darcs.haskell.org/ghc
[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 (
11 createCTagsWithLineNumbersCmd,
12 createCTagsWithRegExesCmd,
13 createETagsFileCmd
14 ) where
15
16 import Exception
17 import GHC
18 import GhciMonad
19 import Outputable
20 import Util
21
22 -- ToDo: figure out whether we need these, and put something appropriate
23 -- into the GHC API instead
24 import Name (nameOccName)
25 import OccName (pprOccName)
26 import MonadUtils
27
28 import Data.Maybe
29 import Panic
30 import Data.List
31 import Control.Monad
32 import System.IO
33 import System.IO.Error
34
35 -----------------------------------------------------------------------------
36 -- create tags file for currently loaded modules.
37
38 createCTagsWithLineNumbersCmd, createCTagsWithRegExesCmd,
39 createETagsFileCmd :: String -> GHCi ()
40
41 createCTagsWithLineNumbersCmd "" =
42 ghciCreateTagsFile CTagsWithLineNumbers "tags"
43 createCTagsWithLineNumbersCmd file =
44 ghciCreateTagsFile CTagsWithLineNumbers file
45
46 createCTagsWithRegExesCmd "" =
47 ghciCreateTagsFile CTagsWithRegExes "tags"
48 createCTagsWithRegExesCmd file =
49 ghciCreateTagsFile CTagsWithRegExes file
50
51 createETagsFileCmd "" = ghciCreateTagsFile ETags "TAGS"
52 createETagsFileCmd file = ghciCreateTagsFile ETags file
53
54 data TagsKind = ETags | CTagsWithLineNumbers | CTagsWithRegExes
55
56 ghciCreateTagsFile :: TagsKind -> FilePath -> GHCi ()
57 ghciCreateTagsFile kind file = do
58 createTagsFile kind file
59
60 -- ToDo:
61 -- - remove restriction that all modules must be interpreted
62 -- (problem: we don't know source locations for entities unless
63 -- we compiled the module.
64 --
65 -- - extract createTagsFile so it can be used from the command-line
66 -- (probably need to fix first problem before this is useful).
67 --
68 createTagsFile :: TagsKind -> FilePath -> GHCi ()
69 createTagsFile tagskind tagsFile = do
70 graph <- GHC.getModuleGraph
71 mtags <- mapM listModuleTags (map GHC.ms_mod graph)
72 either_res <- liftIO $ collateAndWriteTags tagskind tagsFile $ concat mtags
73 case either_res of
74 Left e -> liftIO $ hPutStrLn stderr $ ioeGetErrorString e
75 Right _ -> return ()
76
77
78 listModuleTags :: GHC.Module -> GHCi [TagInfo]
79 listModuleTags m = do
80 is_interpreted <- GHC.moduleIsInterpreted m
81 -- should we just skip these?
82 when (not is_interpreted) $
83 let mName = GHC.moduleNameString (GHC.moduleName m) in
84 ghcError (CmdLineError ("module '" ++ mName ++ "' is not interpreted"))
85 mbModInfo <- GHC.getModuleInfo m
86 case mbModInfo of
87 Nothing -> return []
88 Just mInfo -> do
89 mb_print_unqual <- GHC.mkPrintUnqualifiedForModule mInfo
90 let unqual = fromMaybe GHC.alwaysQualify mb_print_unqual
91 let names = fromMaybe [] $GHC.modInfoTopLevelScope mInfo
92 let localNames = filter ((m==) . nameModule) names
93 mbTyThings <- mapM GHC.lookupName localNames
94 return $! [ tagInfo unqual exported kind name realLoc
95 | tyThing <- catMaybes mbTyThings
96 , let name = getName tyThing
97 , let exported = GHC.modInfoIsExportedName mInfo name
98 , let kind = tyThing2TagKind tyThing
99 , let loc = srcSpanStart (nameSrcSpan name)
100 , RealSrcLoc realLoc <- [loc]
101 ]
102
103 where
104 tyThing2TagKind (AnId _) = 'v'
105 tyThing2TagKind (ADataCon _) = 'd'
106 tyThing2TagKind (ATyCon _) = 't'
107 tyThing2TagKind (ACoAxiom _) = 'x'
108
109
110 data TagInfo = TagInfo
111 { tagExported :: Bool -- is tag exported
112 , tagKind :: Char -- tag kind
113 , tagName :: String -- tag name
114 , tagFile :: String -- file name
115 , tagLine :: Int -- line number
116 , tagCol :: Int -- column number
117 , tagSrcInfo :: Maybe (String,Integer) -- source code line and char offset
118 }
119
120
121 -- get tag info, for later translation into Vim or Emacs style
122 tagInfo :: PrintUnqualified -> Bool -> Char -> Name -> RealSrcLoc -> TagInfo
123 tagInfo unqual exported kind name loc
124 = TagInfo exported kind
125 (showSDocForUser unqual $ pprOccName (nameOccName name))
126 (showSDocForUser unqual $ ftext (srcLocFile loc))
127 (srcLocLine loc) (srcLocCol loc) Nothing
128
129
130 collateAndWriteTags :: TagsKind -> FilePath -> [TagInfo] -> IO (Either IOError ())
131 -- ctags style with the Ex exresion being just the line number, Vim et al
132 collateAndWriteTags CTagsWithLineNumbers file tagInfos = do
133 let tags = unlines $ sortLe (<=) $ map showCTag tagInfos
134 tryIO (writeFile file tags)
135
136 -- ctags style with the Ex exresion being a regex searching the line, Vim et al
137 collateAndWriteTags CTagsWithRegExes file tagInfos = do -- ctags style, Vim et al
138 tagInfoGroups <- makeTagGroupsWithSrcInfo tagInfos
139 let tags = unlines $ sortLe (<=) $ map showCTag $concat tagInfoGroups
140 tryIO (writeFile file tags)
141
142 collateAndWriteTags ETags file tagInfos = do -- etags style, Emacs/XEmacs
143 tagInfoGroups <- makeTagGroupsWithSrcInfo $filter tagExported tagInfos
144 let tagGroups = map processGroup tagInfoGroups
145 tryIO (writeFile file $ concat tagGroups)
146
147 where
148 processGroup [] = ghcError (CmdLineError "empty tag file group??")
149 processGroup group@(tagInfo:_) =
150 let tags = unlines $ map showETag group in
151 "\x0c\n" ++ tagFile tagInfo ++ "," ++ show (length tags) ++ "\n" ++ tags
152
153
154 makeTagGroupsWithSrcInfo :: [TagInfo] -> IO [[TagInfo]]
155 makeTagGroupsWithSrcInfo tagInfos = do
156 let byFile op ti0 ti1 = tagFile ti0 `op` tagFile ti1
157 groups = groupBy (byFile (==)) $ sortLe (byFile (<=)) tagInfos
158 mapM addTagSrcInfo groups
159
160 where
161 addTagSrcInfo [] = ghcError (CmdLineError "empty tag file group??")
162 addTagSrcInfo group@(tagInfo:_) = do
163 file <- readFile $tagFile tagInfo
164 let byLine ti0 ti1 = tagLine ti0 <= tagLine ti1
165 sortedGroup = sortLe byLine group
166 return $ perFile sortedGroup 1 0 $ lines file
167
168 perFile allTags@(tag:tags) cnt pos allLs@(l:ls)
169 | tagLine tag > cnt =
170 perFile allTags (cnt+1) (pos+fromIntegral(length l)) ls
171 | tagLine tag == cnt =
172 tag{ tagSrcInfo = Just(l,pos) } : perFile tags cnt pos allLs
173 perFile _ _ _ _ = []
174
175
176 -- ctags format, for Vim et al
177 showCTag :: TagInfo -> String
178 showCTag ti =
179 tagName ti ++ "\t" ++ tagFile ti ++ "\t" ++ tagCmd ++ ";\"\t" ++
180 tagKind ti : ( if tagExported ti then "" else "\tfile:" )
181
182 where
183 tagCmd =
184 case tagSrcInfo ti of
185 Nothing -> show $tagLine ti
186 Just (srcLine,_) -> "/^"++ foldr escapeSlashes [] srcLine ++"$/"
187
188 where
189 escapeSlashes '/' r = '\\' : '/' : r
190 escapeSlashes '\\' r = '\\' : '\\' : r
191 escapeSlashes c r = c : r
192
193
194 -- etags format, for Emacs/XEmacs
195 showETag :: TagInfo -> String
196 showETag TagInfo{ tagName = tag, tagLine = lineNo, tagCol = colNo,
197 tagSrcInfo = Just (srcLine,charPos) }
198 = take colNo srcLine ++ tag
199 ++ "\x7f" ++ tag
200 ++ "\x01" ++ show lineNo
201 ++ "," ++ show charPos
202 showETag _ = ghcError (CmdLineError "missing source file info in showETag")
203