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