Build fixes
[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 dflags <- getDynFlags
90 mb_print_unqual <- GHC.mkPrintUnqualifiedForModule mInfo
91 let unqual = fromMaybe GHC.alwaysQualify mb_print_unqual
92 let names = fromMaybe [] $GHC.modInfoTopLevelScope mInfo
93 let localNames = filter ((m==) . nameModule) names
94 mbTyThings <- mapM GHC.lookupName localNames
95 return $! [ tagInfo dflags unqual exported kind name realLoc
96 | tyThing <- catMaybes mbTyThings
97 , let name = getName tyThing
98 , let exported = GHC.modInfoIsExportedName mInfo name
99 , let kind = tyThing2TagKind tyThing
100 , let loc = srcSpanStart (nameSrcSpan name)
101 , RealSrcLoc realLoc <- [loc]
102 ]
103
104 where
105 tyThing2TagKind (AnId _) = 'v'
106 tyThing2TagKind (ADataCon _) = 'd'
107 tyThing2TagKind (ATyCon _) = 't'
108 tyThing2TagKind (ACoAxiom _) = 'x'
109
110
111 data TagInfo = TagInfo
112 { tagExported :: Bool -- is tag exported
113 , tagKind :: Char -- tag kind
114 , tagName :: String -- tag name
115 , tagFile :: String -- file name
116 , tagLine :: Int -- line number
117 , tagCol :: Int -- column number
118 , tagSrcInfo :: Maybe (String,Integer) -- source code line and char offset
119 }
120
121
122 -- get tag info, for later translation into Vim or Emacs style
123 tagInfo :: DynFlags -> PrintUnqualified -> Bool -> Char -> Name -> RealSrcLoc
124 -> TagInfo
125 tagInfo dflags unqual exported kind name loc
126 = TagInfo exported kind
127 (showSDocForUser dflags unqual $ pprOccName (nameOccName name))
128 (showSDocForUser dflags unqual $ ftext (srcLocFile loc))
129 (srcLocLine loc) (srcLocCol loc) Nothing
130
131
132 collateAndWriteTags :: TagsKind -> FilePath -> [TagInfo] -> IO (Either IOError ())
133 -- ctags style with the Ex exresion being just the line number, Vim et al
134 collateAndWriteTags CTagsWithLineNumbers file tagInfos = do
135 let tags = unlines $ sortLe (<=) $ map showCTag tagInfos
136 tryIO (writeFile file tags)
137
138 -- ctags style with the Ex exresion being a regex searching the line, Vim et al
139 collateAndWriteTags CTagsWithRegExes file tagInfos = do -- ctags style, Vim et al
140 tagInfoGroups <- makeTagGroupsWithSrcInfo tagInfos
141 let tags = unlines $ sortLe (<=) $ map showCTag $concat tagInfoGroups
142 tryIO (writeFile file tags)
143
144 collateAndWriteTags ETags file tagInfos = do -- etags style, Emacs/XEmacs
145 tagInfoGroups <- makeTagGroupsWithSrcInfo $filter tagExported tagInfos
146 let tagGroups = map processGroup tagInfoGroups
147 tryIO (writeFile file $ concat tagGroups)
148
149 where
150 processGroup [] = ghcError (CmdLineError "empty tag file group??")
151 processGroup group@(tagInfo:_) =
152 let tags = unlines $ map showETag group in
153 "\x0c\n" ++ tagFile tagInfo ++ "," ++ show (length tags) ++ "\n" ++ tags
154
155
156 makeTagGroupsWithSrcInfo :: [TagInfo] -> IO [[TagInfo]]
157 makeTagGroupsWithSrcInfo tagInfos = do
158 let byFile op ti0 ti1 = tagFile ti0 `op` tagFile ti1
159 groups = groupBy (byFile (==)) $ sortLe (byFile (<=)) 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 byLine ti0 ti1 = tagLine ti0 <= tagLine ti1
167 sortedGroup = sortLe byLine group
168 return $ perFile sortedGroup 1 0 $ lines file
169
170 perFile allTags@(tag:tags) cnt pos allLs@(l:ls)
171 | tagLine tag > cnt =
172 perFile allTags (cnt+1) (pos+fromIntegral(length l)) ls
173 | tagLine tag == cnt =
174 tag{ tagSrcInfo = Just(l,pos) } : perFile tags cnt pos allLs
175 perFile _ _ _ _ = []
176
177
178 -- ctags format, for Vim et al
179 showCTag :: TagInfo -> String
180 showCTag ti =
181 tagName ti ++ "\t" ++ tagFile ti ++ "\t" ++ tagCmd ++ ";\"\t" ++
182 tagKind ti : ( if tagExported ti then "" else "\tfile:" )
183
184 where
185 tagCmd =
186 case tagSrcInfo ti of
187 Nothing -> show $tagLine ti
188 Just (srcLine,_) -> "/^"++ foldr escapeSlashes [] srcLine ++"$/"
189
190 where
191 escapeSlashes '/' r = '\\' : '/' : r
192 escapeSlashes '\\' r = '\\' : '\\' : r
193 escapeSlashes c r = c : r
194
195
196 -- etags format, for Emacs/XEmacs
197 showETag :: TagInfo -> String
198 showETag TagInfo{ tagName = tag, tagLine = lineNo, tagCol = colNo,
199 tagSrcInfo = Just (srcLine,charPos) }
200 = take (colNo - 1) srcLine ++ tag
201 ++ "\x7f" ++ tag
202 ++ "\x01" ++ show lineNo
203 ++ "," ++ show charPos
204 showETag _ = ghcError (CmdLineError "missing source file info in showETag")
205