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