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